perm filename LISP.MAC[LSP,LSP] blob
sn#078755 filedate 1974-01-15 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00091 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00006 00002 SUBTTL AC DEFINITIONS AND EXTERNALS --- PAGE 1
C00012 00003 Comment
C00021 00004 DCS 8-73 LSPLOC -- device and ppn specifications
C00022 00005 SUBTTL TOP LEVEL AND INITIALIZATION --- PAGE 2
C00025 00006
C00026 00007 SUBTTL APR INTERRUPT ROUTINES --- PAGE 3
C00028 00008 SUBTTL UUO HANDLER AND SUBR CALL ROUTINES --- PAGE 4
C00032 00009
C00033 00010
C00034 00011
C00036 00012
C00037 00013 Error Handler and Backtrace --- ERRSUB, ERRIO, OUTRET
C00040 00014
C00042 00015 ERROR, ERROR1, ERRORG, STRTYP -- dispatcher for error message uuos
C00047 00016 ERROR2
C00049 00017
C00050 00018 BKTRC, BAKGAG
C00053 00019 Tyi and Tyo -- TYI, TYID, TYIFN, FIXSP
C00062 00020 TYO, TYOD, TYOFN, LINELENGTH, BUFFER (FORCE)
C00069 00021
C00070 00022 Input and Output Initialization and Control -- SIXMAK, NXTIO, SIXRT
C00072 00023 IOSUB, CHNSUB, Channel table definitions.
C00079 00024 TABSRC, TABSR1, IOBRST (NEEDMR, DEVCLR)
C00082 00025 INPUT
C00085 00026 OUTPUT
C00088 00027 INOUT
C00091 00028 USETI, USETO, CHSETI, CHSETO
C00095 00029
C00097 00030
C00100 00031
C00102 00032
C00103 00033 SUBTTL PRINT --- PAGE 8
C00105 00034
C00110 00035 SUBTTL SUPER FAST TABLE DRIVEN READ 14-MAY-69 PAGE 9
C00112 00036
C00113 00037
C00115 00038
C00117 00039
C00119 00040
C00120 00041
C00121 00042
C00124 00043
C00127 00044
C00128 00045 SUBTTL LISP INTERPRETER SUBROUTINES --- PAGE 10
C00130 00046
C00132 00047
C00133 00048
C00134 00049
C00135 00050
C00136 00051
C00137 00052
C00138 00053
C00139 00054
C00140 00055
C00141 00056
C00143 00057
C00146 00058 SUBTTL ARITHMETIC SUBROUTINES --- PAGE 11
C00147 00059
C00148 00060
C00149 00061
C00150 00062
C00151 00063
C00153 00064 SUBTTL EXPLODE, READLIST AND FRIENDS --- PAGE 12
C00154 00065
C00156 00066 SUBTTL EVAL APPLY -- THE INTERPRETER --- PAGE 13
C00158 00067
C00160 00068
C00161 00069
C00162 00070
C00163 00071
C00164 00072
C00165 00073
C00167 00074
C00168 00075
C00170 00076
C00174 00077 SUBTTL ARRAY SUBROUTINES --- PAGE 14
C00178 00078
C00179 00079 SUBTTL EXAMINE, DEPOSIT , ETC --- PAGE 15
C00180 00080 SUBTTL GARBAGE COLLECTER --- PAGE 16
C00187 00081 SUBTTL GETSYM --- PAGE 17
C00189 00082 SUBTTL ALVINE AND LOADER INTERFACES --- PAGE 18
C00195 00083
C00197 00084 SUBTTL REALLOC CODE --- PAGE 19
C00202 00085
C00204 00086 SUBTTL LISP ATOMS AND OBLIST --- PAGE 20
C00206 00087
C00209 00088
C00211 00089 SUBTTL LISP STORAGE ALLOCATOR (ONCE ONLY) --- PAGE 21
C00220 00090 ALLC20: SUBI A,1000
C00224 00091
C00225 ENDMK
C⊗;
SUBTTL AC DEFINITIONS AND EXTERNALS --- PAGE 1
TITLE LISP INTERPRETER
; Revised 8-73 by D. Swinehart (DCS) -- See below
IF1,<PURGE CDR,DF>
MLON
INUMIN=377777
INUM0=<INUMIN+777777>/2
BCKETS==177
ML2==-1
IFNDEF ML2,<ML2==0> ;Special code for MLISP2 (see ML2SET)
;accumulator definitions
;`sacred' means sacred to the interpreter
;`marked' means marked from by the garbage collector
;`protected' means protected during garbage collection
NIL=0 ;sacred, marked, protected ;atom head of NIL
A=1 ;marked, protected ;results of functions and first arg of subrs
B=A+1 ;marked, protected ;second arg of subrs
C=B+1 ;marked, protected ;third arg of subrs
AR1=4 ;marked, protected ;fourth arg of subrs
AR2A=5 ;marked, protected ;fifth arg of subrs
T=6 ;marked, protected ;minus number of args in LSUBR call
TT=7 ;marked, protected
REL=10 ;marked, protected ;rarely used
IFN ML2,<
SSTACK==10 ;status stack
TSTACK==11 ;token stack
>;ML2
S=11 ;rarely used
D=12
R=13 ;protected
P=14 ;sacred, protected ;regular push down stack pointer
F=15 ;sacred ;free storage list pointer
FF=16 ;sacred ;full word list pointer
SP=17 ;sacred, protected ;special pushdown stack pointer
NACS==5 ;number of argument acs
X==0 ;X indicates impure (modified) code locations
TEN==↑D10
;UUO definitions
;UUOs used to call functions from compiled code
;the number of arguments is given by the ac field
;the address is a pointer either to the function
;name or the code of the function
OPDEF FCALL [34B8] ;ordinary function call-may be changed to PUSHJ
OPDEF JCALL [35B8] ;terminal function call-may be changed to JRST
OPDEF CALLF [36B8] ;like call but may not be changed to PUSHJ
OPDEF JCALLF [37B8] ;like jcall but may not be changed to JRST
;error UUOs
OPDEF ERR1 [1B8] ;ordinary lisp error ;gives backtrace
OPDEF ERR2 [2B8] ;space overflow error ;no backtrace
OPDEF ERR3 [3B8] ;ill. mem. ref.
OPDEF STRTIP [4B8] ;print error message and continue
;system UUOs
OPDEF TTYUUO [51B8]
OPDEF INCHRW [TTYUUO 0,]
OPDEF OUTCHR [TTYUUO 1,]
OPDEF OUTSTR [TTYUUO 3,]
OPDEF INCHWL [TTYUUO 4,]
OPDEF INCHSL [TTYUUO 5,]
OPDEF CLRBFI [TTYUUO 11,]
OPDEF INSKIP [TTYUUO 13,]
DEFINE TALK <
INSKIP ;This turns off Control-O. It is easier than the
JFCL ; previous kludge, so I changed you (DCS)
>
;I/O bits and constants
TTYLL==105 ;teletype linelength
LPTLL==160 ;line printer linelength
MLIOB==203 ;max length of I/O buffer
NIOB==2 ;no of I/O buffers per device
NIOCH==17 ;number of I/O channels
FSTCH==1 ;first I/O channel
TTCH==0 ;teletype I/O channel
BLKSIZE==NIOB*MLIOB+COUNT+1
INB==2
OUTB==1
AVLB==40
DIRB==4
;special ASCII characters
ALTMOD==175
SPACE==40 ;space
IGCRLF==32 ;ignored cr-lf
RUBOUT==177
LF==12
CR==15
TAB==11
BELL==7
DBLQT==42 ;double quote "
;byte pointer field definitions
ACFLD==14 ;ac field
XFLD==21 ;index field
OPFLD==10 ;opcode field
ADRFLD==43 ;adress field
;external and internal symbols
EXTERNAL JOB41 ;instruction to be executed on UUO
EXTERNAL JOBAPR ;address of APR interupt routines
EXTERNAL JOBCNI ;interupt condition flags
EXTERNAL JOBFF ;first location beyond program
EXTERNAL JOBREL ;address of last legal instruction in core image
EXTERNAL JOBREN ;reentry address
EXTERNAL JOBSA ;starting address
EXTERNAL JOBSYM ;address of symbol table
EXTERNAL JOBTPC ;program counter at time of interupt
EXTERNAL JOBUUO ;uuo is put here with effective address computed
;apr flags
PDOV==200000 ;push down list overflow
MPV==20000 ;memory protection violation
NXM==10000 ;non-existant memory referenced
APRFLG==PDOV+MPV+NXM ;any of the above
;system uuos
APRINI==16
RESET==0
STIME==27
DEVCHR==4
EXIT==12
CORE==11
Comment ⊗
DCS Revisions: 8-73 -- the modifications will be further commented
in the code, identified by the subject titles as given below.
Visible (to user):
PRINT -- The PRINT, PRIN1, TYO, etc. routines no longer send
teletype output characters to the system one at a time.
Instead, each buffers all its characters, printing them
with a single UUO just before they return (but see BUFFER
below). All previous routines are renamed, so that PRINT
becomes .PRINT, TYO → .TYO, etc. The PRINT, TYO, etc.,
routines call their dotted corresponding functions, then
(perhaps, see BUFFER) FORCE their output. The result
is a massive improvement in speed (at least 4:1).
(BUFFER T) inhibits the FORCing action at the end of all print
routines. Characters will be buffered until the buffer
overflows (system TTY buffer sized) or until the following
function call is executed. BUFFER returns the previous
value of the BUFFER flag.
(BUFFER NIL) forces any buffered output, then allows normal
FORCing actions to proceed.
RANDOM -- This set of facilities allows extension of old files, and
some random access to files.
(INOUT channel filespec) behaves like INPUT or OUTPUT, except
that the file is opened in update (or extend) mode, available
for either input or output. (INC channel flag) or
(OUTC channel flag) are both legal, and will read or write
from the current input or output pointer position.
(USETI channel number) will set the file input pointer for any
input or inout file to the <numberth> ↑D128 word record
in the file (standard USETI). It returns the previous
pointer value.
(USETI channel NIL) will not change the input pointer, but will
simply return the current record number.
(USETO channel number) sets the file output pointer to the
<numberth> record (they are really both the same pointer),
returning the old value.
(USETO channel NIL) simply returns the old value.
(USETO channel T) sets the file output pointer to the first record
beyond the current end of file (allows extension). It
returns the RESULTANT NUMBER, so call (USETO ... NIL) to
get the old value first, if you want it.
SPEAK -- SPEAK has been turned into an FSUBR, and given an optional
numeric argument.
(SPEAK) will return the current CONS count, as before.
(SPEAK n) will do the same, but will set the CONS count to <n>
before returning.
This was done because after the CONS count exceeds the INUM0
value, SPEAK does two CONSes to create the resultant FIXNUM,
making accurate counting difficult.
Invisible to User:
LSPLOC -- For the nonce, we can have two active interpreters at once
by causing SYSINI to load LISP.xxx from a specified device
(SYS or DSK) and ppn (if DSK), assembled in. We will have
to device an eventual plan for doing this. This will allow
people with old interpreters embedded in their coreimages
to continue to use them.
DCS REVISIONS 9-73.
USERIO -- This facility allows the user to define his own I/O "devices"
by providing his own TYI and TYO routines. The interpretation
of a "file name" following device "FN:" in any INPUT, OUTPUT, or
INOUT (see above) call is that "file name" is really a function
name. This function will be called instead of TYI or TYO, whenever
that channel is selected. The USERIO function should be declared
as:
(DE USERIO (CODE CHAR) ( ... ))
CODE is NIL for TYI, T for TYO. This allows the same function
to be used for both, in the case of INOUT. Later extensions may
provide CODEs for USETI and USETO.
CHAR is NIL for TYI, the INUM representing an ASCII character for TYO --
the character which would have been output.
USERIO should return an ASCII character (an INUM) for TYI, or $EOF$ to
simulate an end of file condition. USERIO's value is
ignored for TYO: since the published value of TYO is its input,
the interpreter forces this result.
Within USERIO (or whatever name you choose) you can execute
INC and OUTC functions to select other channels. You can then
recursively call TYI or TYO (perhaps even PRINT, etc.) This
allows you, for instance, to record what is being read from
some real file, or what is being written to some real file.
(CHRVAL X) yields as an INUM the ASCII value of the first character
in the PNAME of X. It is useful for providing values for the
TYI USERIO function.
COUNTERS
The interpreter gives the counter package a little help. This is
very special purpose, as is ML2SET.
(CNTSET (FUNCTION X)) provides the address of the SUBR X to the interpreter.
X is called at a strategic point during the UUO call of a compiled
function from another compiled function, with ACs set up in wondrous
ways. X should be written knowing what these values are. (Typically,
the function X records the number of calls on the function being called).
MLISP2 help
(ML2SET (FUNCTION X)) provides the address of a complicated MLISP2 function
to the interpreter, and returns the address of a data value needed
by MLISP2 LAP code. Very special purpose.
⊗
; DCS 8-73 LSPLOC -- device and ppn specifications
DEFINE LSPDEV <SIXBIT /DSK/> ;For now, new interp. gets files from here
DEFINE LSPPPN <SIXBIT /LSPSYS/> ; more specifically, here (SEE END FOR DEF)
;foolst macros
DEFINE FOO <
XLIST
BAZ (\FOOCNT)
LIST
>
DEFINE BAZ (X)
<FOOCNT=FOOCNT+1
FOO'X:
>
FOOCNT=0
SUBTTL TOP LEVEL AND INITIALIZATION --- PAGE 2
LISPGO: SETOM RETFLG# ;enter via INITFN
JRST STRT ;go to re-allocator
DEBUGO: SETZM RETFLG ;clear return flag to allow INITFN to be changed
;**** JRST LISP1X ;entry point to get into read-eval-print loop
;without unbinding spec pdl
;**** This patch allows GET/REE... much more control needed
START: CALLI RESET ;random initializations for lisp interupts
MOVE [JSR UUOH]
MOVEM JOB41
MOVEI APRINT
MOVEM JOBAPR
MOVEI APRFLG
CALLI APRINI
HRRZI 17,1
SETZB 0,PSAV1
BLT 17,17 ;clear acs
LSPRT1: SETOM ERRSW ;print error messages
CLEARM ERRTN ;return to top level on errors
SETOM PRVCNT# ;initialize counter for errio
MOVE P,C2# ;initial reg pdl ptr
MOVE SP,SC2# ;initial spec pdl ptr
LISP1X: PUSHJ P,TTYRET ;(outc nil t)(inc nil t)return output for gc message
FOO HRROI NIL,CNIL2 ;initialize nil
PUSHJ P,FORSET ;DCS 8-73 PRINT -- initialize TTY output buffer
SKIPE HASHFG#
JRST REHASH ;rehash if necessary
SKIPN FF+X
PUSHJ P,AGC ;garbage collect only if necessary
SKIPN BSFLG# ;initial bootstrap for macros
JRST BOOTS
SKIPE RETFLG ;test for error return
JRST [ SKIPE A,INITF
CALLF (A) ;evaluate initialization function
SETZM RETFLG
JRST .+1]
LISP2: PUSHJ P,TTYRET ;return all i/o to tty
PUSHJ P,FORSET ;DCS 8-73 PRINT -- init tty output buffer
PUSHJ P,TERPRI
SKIPE GOBF# ;garbaged oblist flag
STRTIP [SIXBIT /GARBAGED OBLIST←!/]
SETZM GOBF
SKIPE BPSFLG#
JRST BINER2 ;binary program space exceeded by loader
LISP1: PUSHJ P,READ ;this is the top level of lisp
PUSHJ P,EVAL
PUSHJ P,PRINT
PUSHJ P,TERPRI
JRST LISP1
INITFN: EXCH A,INITF#
POPJ P,
;return from lisp error or bell
LSPRET: PUSHJ P,TERPRI
SKIPE PSAV1# ;bell from alvine?
JRST [ MOVE P,PSAV1 ;yes, return to alvine
HRRZ REL,ED
JRST 1(REL)] ;improved magic
MOVE B,SC2
PUSHJ P,UBD ;unbind specpdl
SETOM RETFLG ;set return flag
JRST LSPRT1
.RSET: EXCH A,RSTSW#
POPJ P,
;bootstrapper for macro definitions
BOOTS: SETOM BSFLG
MOVEI A,BSTYI
PUSHJ P,READP1
PUSHJ P,EVAL
PUSHJ P,READ
JRST .-2
BSTYI: ILDB A,[POINT 7,[ASCII /(INC(INPUT SYS:(LISP.LSP)))/]]
POPJ P,
SUBTTL APR INTERRUPT ROUTINES --- PAGE 3
;arithmetic processor interupts
;mem. protect. violation, nonex. mem. or pdl overflow
APRINT: MOVE R,JOBCNI ;get interupt bits
TRNE R,MPV+NXM ;what kind
ERR3 @JOBTPC ;an ill mem ref-will become JRST ILLMEM
JUMPN NIL,MES21 ;a pdl overflow
STRTIP [SIXBIT /←PDL OVERFLOW FROM GC - CAN'T CONTINUE!/]
JRST START
MES21: SETZM JOBUUO
SKIPL P
STRTIP [SIXBIT /←REG !/]
SKIPL SP
STRTIP [SIXBIT /←SPEC !/]
SKIPE JOBUUO
SPDLOV: ERR2 [SIXBIT /PUSHDOWN CAPACITY EXCEEDED !/]
TRNE R,PDOV
SKIPE JOBUUO
HALT ;lisp should not be here
BINER2: SETZM BPSFLG
ERR2 [SIXBIT /BINARY PROGRAM SPACE EXCEEDED !/]
ILLMEM: LDB R,[POINT 4,@JOBTPC,XFLD] ;get index field of bad word
CAIE R,F ;does it contain f
ERR3 @JOBTPC ;no! error
PUSHJ P,AGC ;yes! garbage collect
JRST @JOBTPC ;and continue
SUBTTL UUO HANDLER AND SUBR CALL ROUTINES --- PAGE 4
UUOMIN==1
UUOMAX==4
UUOH: X ;jsr location
MOVEM T,TSV#
MOVEM TT,TTSV#
LDB T,[POINT 9,JOBUUO,OPFLD] ;get opcode
CAIGE T,34 ;is it a function call
JRST ERROR ;or a LISP error
HLRE R,@JOBUUO
AOJN R,UUOS
LDB T,[POINT 4,JOBUUO,ACFLD]
CAILE T,15
MOVEI R,-15(T)
HRRZ T,@JOBUUO
UUOH1: HLRZ TT,(T)
HRRZ T,(T)
SKIPE CNTROUT# ;COUNTER ROUTINE ENABLED?
PUSHJ P,@CNTROUT ;YES, CALL IT
FOO CAIN TT,SUBR
JRST @UUST(R)
FOO CAIN TT,FSUBR
JRST @UUFST(R)
FOO CAIN TT,LSUBR
JRST @UULT(R)
FOO CAIN TT,EXPR
JRST @UUET(R)
FOO CAIN TT,FEXPR
JRST @UUFET(R)
HRRZ T,(T)
JUMPN T,UUOH1
PUSH P,A
PUSH P,B
HRRZ A,JOBUUO
FOO MOVEI B,VALUE
PUSHJ P,GET
JUMPN A,[ HRRZ TT,(A)
POP P,B
POP P,A
JRST UUOEX1]
HRRZ A,JOBUUO
PUSHJ P,EPRINT
ERR1 [SIXBIT /UNDEFINED UUO!/]
SKIPA T,TT
UUOSBR: HLRZ T,(T)
MOVE TT,JOBUUO
HRLI T,(PUSHJ P,)
TLNE TT,1000 ;1000 means no push
TLCA T,34600 ;<PUSHJ P,>xor<JRST>
PUSH P,UUOH
SOS UUOH
UUOCL: TLNN TT,2000+X ;2000 means no clobber
MOVEM T,@UUOH
MOVE TT,TTSV
EXCH T,TSV
JRST @TSV
UUOS: HRRZ TT,JOBUUO
CAILE TT,@GCPP1
CAIL TT,@GCP1
JRST UUOSBR-1
JRST .+2
UUOEXP: HLRZ TT,(T)
UUOEX1: LDB T,[POINT 5,JOBUUO,ACFLD]
TRZN T,20
PUSH P,UUOH
PUSH P,TT
JUMPE T,IAPPLY
CAIN T,17
MOVEI T,1
MOVNS T
HRLZ TT,T
PUSH P,A(TT)
AOBJN TT,.-1
JRST IAPPLY
ARGPDL: LDB T,[POINT 4,JOBUUO,ACFLD]
MOVNS T
HRLZ R,T
ARGP1: JUMPE R,(TT)
PUSH P,A(R)
AOBJN R,.-1
JRST (TT)
QTIFY: PUSHJ P,NCONS
FOO MOVEI B,CQUOTE
JRST XCONS
QTLFY: MOVEI A,0
QTLFY1: JUMPE T,(TT)
EXCH A,(P)
PUSHJ P,QTIFY
POP P,B
PUSHJ P,CONS
AOJA T,QTLFY1
PDLARG: JRST .+NACS+2(T)
POP P,A+5
POP P,A+4
POP P,A+3
POP P,A+2
POP P,A+1
POP P,A
JRST (TT)
NOUUO: MOVSI B,(TLNN TT,)
SKIPE A
MOVSI B,(TLNA)
HLLM B,UUOCL
EXCH A,NOUUOF#
POPJ P,
CNTSET: EXCH A,CNTROUT#
POPJ P,
;r=0 => compiler calling a -
;r=1 => compiler calling a lsubr
;r=2 => compiler calling f type
UUST: UUOSBR
UUOS1 ;calling l its a subr
UUOS2 ;calling f
UUFST: UUOS9 ;calling - its a f
UUOS10 ;calling l
UUOSBR
UULT: UUOS7 ;calling - its a l
UUOSBR
UUOS8
UUET: UUOEXP
UUOS5 ;calling l its an expr
UUOS6 ;calling f its an expr
UUFET: UUOS3 ;calling - its a fexpr
UUOS4 ;calling l
UUOEXP
UUOS1: HLRZ R,(T)
MOVE T,TSV
JSP TT,PDLARG
JRST (R)
UUOS3: PUSH P,(T)
JSP TT,ARGPDL
UUOS4A: JSP TT,QTLFY
MOVEI TT,1
DPB TT,[POINT 4,JOBUUO,ACFLD]
UUOS6A: POP P,TT
HLRZS TT
JRST UUOEX1
UUOS4: PUSH P,(T)
MOVE T,TSV
JRST UUOS4A
UUOS5: HLRZ R,(T)
MOVE T,TSV
JSP TT,PDLARG
MOVE TT,R
JRST UUOEX1
UUOS6: PUSH P,(T)
PUSH P,UUOH
PUSH P,JOBUUO
JSP TT,ILIST
JSP TT,PDLARG
POP P,JOBUUO
POP P,UUOH
JRST UUOS6A
UUOS8: SKIPA TT,CILIST
UUOS7: MOVEI TT,ARGPDL
HRRM TT,UUOS7A
MOVE TT,JOBUUO
TLNN TT,1000
PUSH P,UUOH
HLRZ TT,(T)
UUOS7A: JRST ARGPDL+X ;or ilist
UUOS9: PUSH P,T
JSP TT,ARGPDL
UUS10A: JSP TT,QTLFY
MOVSI T,2000
IORM T,JOBUUO
POP P,T
JRST UUOSBR
UUOS10: PUSH P,T
MOVE T,TSV
JRST UUS10A
SUBTTL Error Handler and Backtrace --- ERRSUB, ERRIO, OUTRET
;subroutine to print sixbit error message
ERRSUB: MOVSI A,(POINT 6,0)
HRR A,JOBUUO
MOVEM A,ERRPTR#
ERRORB: ILDB A,ERRPTR
CAIN A,01 ;conversion from sixbit
POPJ P,
CAIN A,77
JRST [ PUSHJ P,TERPRI
JRST ERRORB]
ADDI A,40
PUSHJ P,TYO
JRST ERRORB
; DCS 9-73 -- THIS CODE PREVIOUSLY ONLY PARTIALLY DE-SELECTED THE
; CURRENT OUTPUT CHANNEL, ONLY PARTIALLY SWITCHING TO TTY. NOW
; IT COMPLETELY DOES IT, SO THAT (CHRCT) DOESN'T GET SCREWED UP BY
; GC
ERRIO: MOVE B,ERRSW ;IF NIL, WE WON'T GET HERE
CAIN B,INUM0 ;inum0 (lisp 0) specifies to print message
POPJ P, ; on selected device
TALK ;undo control o
PUSH P,A
SETZB A,B ; (INC NIL NIL)
PUSHJ P,OUTC
MOVEM A,PRVSEL# ;save deselected channel
JRST POPAJ
OUTRET: MOVE A,PRVSEL ;(INC PRVSEL NIL)
MOVEI B,NIL ; reselects previous channel
JRST OUTC
ERRTN: 0 ;0 => top level *
;- => pdl to reset to - stored by errorset
;+ => string tyo pout rtn flag
ERRSW: -1 ;0 means no prnt on error *
;subroutine to search oblist for closest function to address in r
ERSUB3:
FOO MOVEI A,QST
FOO HRROI NIL,CNIL2
HRLZ B,INT1
MOVNS B
SETZB AR2A,GOBF
PUSH P,JOBAPR
MOVEI C,[ SETOM GOBF
JRST ERRO2G]
HRRM C,JOBAPR
HLRZ C,@RHX5
ERRO2B: JUMPE C,[ AOBJN B,.-1
POP P,JOBAPR ;oblist done, restore
JRST PRINC] ;print closest match
HLRZ TT,(C)
ERRO2C: HRRZ TT,(TT)
JUMPE TT,ERRO2G
HLRZ AR1,(TT)
FOO CAIN AR1,LSUBR
JRST ERRO2H
FOO CAIE AR1,SUBR
FOO CAIN AR1,FSUBR
JRST ERRO2H
HRRZ TT,(TT)
JRST ERRO2C
ERRO2H: HRRZ TT,(TT)
HLRZ TT,(TT)
CAMLE TT,AR2A ;le to prefer car to quote
CAMLE TT,R
JRST ERRO2G
MOVE AR2A,TT
HLRZ A,(C)
ERRO2G: HRRZ C,(C)
JRST ERRO2B
;ERROR, ERROR1, ERRORG, STRTYP -- dispatcher for error message uuos
ERROR: MOVEI A,APRFLG
CALLI A,APRINI ;enable interupts
LDB A,[POINT 9,JOBUUO,OPFLD] ;get opcode
CAIL A,UUOMIN ;what
CAILE A,UUOMAX ;is it?
JRST ILLUUO ;an illegal opcode
JRST @ERRTAB-UUOMIN(A) ;or LISP error
ERRTAB: ERROR1 ;1 ;ordinary LISP error
ERRORG ;2 ;space overflow error
ERROR2 ;3 ;ill. mem. ref.
STRTYP ;4 ;print error message and continue
ERRORG: SKIPN P,ERRTN ;if in errset, restore p to that level
MOVE P,C2 ;else to top level
;and attempt to print message
ERROR1: SKIPN ERRSW
JRST ERREND ;dont print message, call (err nil)
PUSHJ P,ERRIO ;print message on tty
PUSHJ P,TERPRI
PUSHJ P,ERRSUB ;print the message
JRST ERRBK ;go the backtrace
STRTYP: PUSHJ P,ERRIO
PUSHJ P,ERRSUB ;print message and continue
PUSHJ P,OUTRET
JRST @UUOH
;ERROR2
ERROR2: HRRZ A,JOBUUO
MOVEI B,[SIXBIT / ILL MEM REF FROM !/]
JRST ERSUB2
ILLUUO: HRRZ A,UUOH
MOVEI B,[SIXBIT / ILL UUO FROM !/]
ERSUB2: SKIPN ERRSW
JRST ERREND ;dont print message
PUSH P,A
PUSH P,B
PUSHJ P,ERRIO
PUSHJ P,TERPRI
PUSHJ P,PRINL2 ;print number
POP P,A
STRTIP (A) ;print message
POP P,R
PUSHJ P,ERSUB3 ;print nearest oblist match
ERRBK: SKIPE BACTRF#
PUSHJ P,BKTRC ;print backtrace
PUSHJ P,OUTRET ;return to previous device
ERREND: MOVEI A,0 ;(err nil)
SKIPN ERRTN
JRST [CLRBFI ;clear input buffer
SKIPE RSTSW
JRST LISP2;(*rset t) goes to read-eval-print loop without unbind
JRST LSPRET] ;unbind and go to top level
ERR: SKIPN ERRTN
JRST LSPRET ;not in an errset, or bad error -- go to top level
MOVE P,ERRTN
ERR1: POP P,B
PUSHJ P,UBD ;unbind to previous errset
POP P,ERRSW
POP P,ERRTN
JRST ERRP4 ;and proceed
ERRSET: PUSH P,PA3
PUSH P,PA4
PUSH P,ERRTN
PUSH P,ERRSW
PUSH P,SP
MOVEM P,ERRTN
HRRZ C,(A)
HLRZ C,(C)
MOVEM C,ERRSW
HLRZ A,(A)
PUSHJ P,EVAL
PUSHJ P,NCONS
JRST ERR1
;error messages
DOTERR: SETZM OLDCH
ERR1 [ SIXBIT /DOT CONTEXT ERROR!/]
UNDFUN: HLRZ A,(AR1)
PUSHJ P,EPRINT
ERR1 [SIXBIT /UNDEFINED FUNCTION!/]
UNBVAR: PUSHJ P,EPRINT
ERR1 [SIXBIT /UNBOUND VARIABLE - EVAL!/]
NONNUM: ERR1 [SIXBIT /NON-NUMERIC ARGUMENT!/]
NOPNAM: ERR1 [SIXBIT /NO PRINT NAME - INTERN!/]
NOLIST: ERR1 [SIXBIT /NO LIST-MAKNAM!/]
TOMANY: ERR1 [SIXBIT /TOO MANY ARGUMENTS SUPPLIED - APPLY!/]
TOOFEW: ERR1 [SIXBIT /TOO FEW ARGUMENTS SUPPLIED - APPLY!/]
UNDTAG: PUSHJ P,EPRINT
ERR1 [SIXBIT /UNDEFINED FUNCTION - APPLY!/]
EG1: HRRZ A,T
PUSHJ P,EPRINT
ERR1 [SIXBIT /UNDEFINED PROG TAG-GO!/]
;BKTRC, BAKGAG
;backtrace subroutine
BKTRC: MOVEI D,-1(P)
MOVN A,BACTRF
ADDI A,INUM0
JUMPL A,[ ADD A,P ;backtrace specific number
JRST .+3]
SKIPN A,ERRTN ;backtrace to previous errset
MOVE A,C2 ;or top level
HRRZM A,BAKLEV#
STRTIP [SIXBIT /←BACKTRACE←!/]
BKTR2: CAMG D,BAKLEV
JRST FALSE ;done
HRRZ A,(D) ;get pdl element
FOO CAIGE A,FS
JUMPN A,.+2 ;this is (hopefully) a true program address
SOJA D,BKTR2 ;not a program address, continue
CAIN A,ILIST3
JRST BKTR1A ;argument evaluation
BKTR1B: CAIN A,CPOPJ
JRST [ HLRZ A,(D) ;calling a function
PUSHJ P,PRINC
XCT "-",CTY
STRTIP [SIXBIT /ENTER !/]
SOJA D,BKTR2]
HLRZ B,-1(A)
CAILE B,(JCALLF 17,@(17))
CAIN B,(PUSHJ P,) ;tests for various types of calls
CAIGE B,(FCALL)
SOJA D,BKTR2 ;not a proper function call
PUSH P,-1(A) ;save object of function call
MOVEI R,-1(A) ;location of function call
PUSHJ P,ERSUB3 ;print closest oblist match
MOVEI A,"-"
PUSHJ P,TYO
POP P,R
TLNE R,17
HRRZ R,ERSUB3 ;qst -- cant handle indexed calls
HRRZS R
HLRO B,(R)
AOSN B
JRST [ HRRZ A,R ;was calling an atomic function
PUSHJ P,PRINC ;print its name
JRST .+2]
PUSHJ P,ERSUB3 ;was calling a code location -- print closest match
MOVEI A," "
PUSHJ P,TYO
BKTR1: SOJA D,BKTR2 ;continue
BKTR1A: HRRZ B,-1(D)
CAIE B,EXP2
CAIN B,ESB1
JRST .+2
JRST BKTR1B ;hum, not really evaluating arguments
HLRE B,-1(D)
ADD B,D
HLRZ A,-3(B)
JUMPE A,BKTR1
PUSHJ P,PRINC
XCT "-",CTY
STRTIP [SIXBIT /EVALARGS !/]
JRST BKTR1
BAKGAG: EXCH A,BACTRF
POPJ P,
SUBTTL Tyi and Tyo -- TYI, TYID, TYIFN, FIXSP
;input
ITYI: PUSHJ P,TYI
FIXI: ADDI A,INUM0
POPJ P,
TYI: MOVEI AR1,1
PUSHJ P,TYIA
JUMPE A,.-1
CAME A,IGSTRT ;start of comment or ignored cr-lf
POPJ P,
PUSHJ P,COMMENT
JRST TYI+1
TYIA: SKIPE A,OLDCH
JRST TYI1
TYID:
TYI2: JRST TTYI+X ;sosg x for other device input, JRST TYIFN+X IF FN-INPUT
;other device input
JRST TYI2X
TYI3: ILDB A,X ;pointer
TYI3A: TDNN AR1,@X ;pointer
POPJ P,
MOVE A,@TYI3A
CAMN A,[<ASCII / />+1] ;page mark for stopgap
AOSA PGNUM ;increment page number
MOVEM A,LINUM
MOVNI A,5
ADDM A,@TYI2 ;adjust character count for line number
AOS @TYI3 ;increment byte pointer over line number and tab
JRST TYI2
TYI2X: INPUT X,
;RANDOM 9-73 DCS
HRRZ A,INCH ;Increment record number for USET.. operations
HRRZ A,CHTAB(A)
AOS CHREC(A)
TYI2Y: STATZ X,740000
ERR1 AIN.8 ;input error
TYI2Z: STATO X,20000
; **********
; JRST TYI3 ;continue with file
JRST COMTST ;CHECK FOR DIRECTORY PAGE
; *******
TIEOF: PUSH P,T ;end of file
PUSH P,C
PUSH P,R
PUSH P,AR1
MOVE A,INCH
HRRZ C,CHTAB(A) ;get location of data for this channel
HLRZ T,CHTAB(A) ;inlst -- remaining files to input
JUMPE T,TYI2E ;none left -- stop
PUSH P,C
PUSHJ P,SETIN ;start next input
POP P,C
; USERIO 9-73 DCS -- reset iofn name if a FN: channel
MOVE AR1,FNNAME(C);function name
SKIPGE CHNAM(C)
MOVEM AR1,IOFN
POP P,AR1
POP P,R
POP P,C
POP P,T
JRST TYI
COMTST: HRRZ A,@TYI3
PUSH P,T
MOVE T,1(A)
CAME T,[ASCII /COMME/]
JRST NOCMNT
MOVE T,2(A)
CAME T,[ASCII /NT ⊗ /]
JRST NOCMNT
COMLP: XCT TYI2X ;INPUT
XCT TYI2Y ;STATZ
JRST AIN.8
XCT TYI2Z ;STATO
JRST .+2
JRST TIEOF+1
HRRZ A,@TYI3
LDB T,[POINT 7,1(A),6]
CAIE T,14
JRST COMLP ;READ TO FF
NOCMNT: POP P,T
JRST TYI3
; USERIO 9-73 DCS -- PRINT and READ use the extension (unused portion) of the
; SP stack to collect atoms, since previous READ/WRITE routines did not use
; this stack. Both routines use register C to record the current address
; (PRINT sometimes uses one more word). FIXSP, called by the TYIFN and TYOFN
; user routine interfaces, saves SP, and updates its current value to point
; beyond the current C, if C looks like it is in this mode (within the
; unused stack portion. The FN routines will restore SP on return.
FIXSP: PUSH P,SP ;Save
HRRZ B,SP ;If the distance between SP and C is
SUBI B,(C) ; positive, and is smaller than the
HLRE C,SP ; distance to the end of the stack area,
JUMPGE B,(AR1) ; update SP to the current value of C.
CAMGE B,C ; (The calculations are carried out using
JRST (AR1) ; the negative values of all the numbers,
MOVNS B ; for convenience when working with stack
ADDI B,1 ; size counts).
HRL B,B
ADD SP,B
JRST (AR1)
; USERIO 9-73 DCS -- TYI interface. When a FN: channel is active for input,
; this routine is called for every TYI. The INC routine has placed the
; atom for the user's routine into IOFN. This routine saves all ACs which
; might get clobbered, calls (USERIO NIL NIL), then returns the first
; character in the PNAME of the resulting (one-character) atom. If
; the atom from the USERIO function is $EOF$, an end of file condition is
; simulated.
TYIFN: HLRE A,P ;Test for enough room to store registers
CAML A,[-R+A] ; B through R
JRST [HRROS P ;No, cause a pdlov
PUSH P,
STRTIP [SIXBIT /PDLOV IN FUNCTION TYI !/]]
HRLI A,B ;BLT B through R onto stack
HRRI A,1(P)
BLT A,R-A(P)
ADD P,[R-A,,R-A]
JSP AR1,FIXSP ;Fix SP as described above.
SETZB A,B ;(IOFN NIL NIL)
CALLF 2,@IOFN# ;Call user getchar routine
POP P,SP ;Restore, tho may not be changed
FOO CAIE A,$EOF$ ;If EOF, leave alone
SUBI A,INUM0 ;Not EOF means INUM for ASCII char. value
TYFN: HRLI R,-R+A+1(P) ;Restore B through R
HRRI R,B
BLT R,R
SUB P,[R-A,,R-A]
FOO CAIN A,$EOF$ ;returned if "EOF", never happens with TYO
JRST TIEOF
POPJ P,
; DCS 8-73 RANDOM -- Modifications to end of file code, to release
; both input and output sides of an INOUT channel.
TYI2E: MOVE A,CHNAM(C); If input file, clear input file part!
TRNN A,400000; check it
SETZM INCHAN(C) ; Input file, don't interpret as update
PUSH P,INCHAN(C); input file part, if update file
PUSHJ P,INCNT ;(inc nil t)
POP P,C ; If update file, do (OUTC NIL T)
JUMPE C,ALDNN ; also
PUSHJ P,OUTCNT; (outc nil t) [old file already released by incnt]
TALK ;turn off control o
ALDNN:
FOO MOVEI A,$EOF$ ;we are done
JRST ERR ;STOPTHISNONSENSE
PGLINE: MOVE C,[POINT 7,LINUM]
PUSHJ P,NUM10 ;convert ascii line number to a integer
PUSHJ P,FIX1A
MOVE B,PGNUM
ADDI B,INUM0+1
JRST XCONS
OLDCH: 0
PGNUM: 0
LINUM: 0
0 ;zero to terminate num10
PAGE ;teletype input
TTYI: SKIPE DDTIFG
JRST TTYID
INCHSL A ;single char if line has been typed
JRST [OUTCHR ["*"] ;output * -- TALK removed because TTYSER fixed.
INCHWL A ;wait for a line
JRST .+1]
TTYXIT: CAIN A,BELL
JRST LSPRET ;bell returns to top level
POPJ P,
TTYID: INCHRW A ;single character input DDT submode style
CAIE A,RUBOUT ;TALK removed because TTYSER works.
JRST TTYXIT
OUTCHR ["\"] ;echo backslash
SKIPE PSAV
JRST RDRUB ;rubout in read resets to top level of read
MOVEI A,RUBOUT
POPJ P,
;TYO, TYOD, TYOFN, LINELENGTH, BUFFER (FORCE)
ITYO: SUBI A,INUM0
PUSHJ P,TYO
JRST FIXI
.TYO: CAIG A,CR
JRST TYO3
SOSGE CHCT
JRST TYO1
.TYOD: JRST .TTYO+X ;sosg x for other device, JRST TYOFN for functional TYO
;other device output
JRST TYO2Z
TYO5: IDPB A,X
POPJ P,
;RANDOM 9-73 DCS
TYO2Z: PUSH P,A ;increment record number for USETx....
HRRZ A,OUTCH
HRRZ A,CHTAB(A)
AOS CHREC(A)
POP P,A
TYO2X: OUT X,
JRST TYO5
ERR1 [SIXBIT /OUTPUT ERROR!/]
TYO1: PUSH P,A ;linelength exceeded
MOVEI A,IGCRLF ;inored cr-lf
PUSHJ P,.TYOD
PUSHJ P,.TERPRI ;force out a cr-lf, with special mark
POP P,A
SOSA CHCT
TYO4: POP P,B
JRST .TYOD
TYO3: CAIGE A,TAB
JUMPN A,.TYO+2 ;everything between 0(null) and 11(tab) decrement chct
PUSH P,B
MOVE B,LINL
CAIN A,TAB
JRST [ SUB B,CHCT
IORI B,7 ;simulate tab effect on chct
SUB B,LINL
SETCAM B,CHCT
JRST TYO4]
CAIN A,CR
MOVEM B,CHCT ;reset chct after a cr
JRST TYO4
; USERIO 9-73 DCS -- TYO interface. When a FN: channel is active for output,
; this routine is called for every TYO. The OUTC routine has placed the
; atom for the user's routine into IOFN. This routine saves all ACs which
; might get clobbered, calls (USERIO T CHAR), where CHAR is a one-character
; atom created from the character to be written. It ignores the result of
; the value returned from the USERIO routine, instead returning its input
; (A).
TYOFN: PUSH P,B ;NEED B, SAVE FIRST
HLRE B,P ;Test for enough room to store registers
CAML B,[-R+A+1] ; B through R
JRST [HRROS P ;No, cause a pdlov
PUSH P,
STRTIP [SIXBIT /PDLOV IN FUNCTION TYO !/]]
HRLI B,C ;BLT B through R onto stack
HRRI B,1(P)
BLT B,R-A-1(P)
ADD P,[R-A-1,,R-A-1]
JSP AR1,FIXSP ;See prev. page, fix up SP
CAMN SP,(P) ;If SP was adjusted, move it out to
JRST NOSPA ; the first zero word, since PRINN
MOVE B,SP
SKIPE (B) ; has pushed data, then a [0], into the
AOBJN B,.-1 ; unused area of the stack, for printing.
JUMPGE B,NOSPA
MOVE SP,B ;(Don't exceed size of stack)
NOSPA: PUSH P,A
MOVEI B,INUM0(A) ;USERIO expects INUM character value
FOO MOVEI A,TRUTH ;(IOFN T CHAR) for output
CALLF 2,@IOFN ;User fn
POP P,A ;Unadulterated input
POP P,SP ;Restore old stack.
JRST TYFN ; Finish up in common code
LINELENGTH:
JUMPE A,LINEL1
PUSHJ P,NUMVAL ;accept very long lines.
MOVEM A,CHCT
EXCH A,LINL
JRST FIXI
LINEL1: MOVE A,LINL
JRST FIXI
CHRCT: MOVE A,CHCT
JRST FIXI
LINL: TTYLL ;*
CHCT: TTYLL ;*
; 8-73 DCS PRINT -- Buffered tty output.
; WARNING is the last word of the tty buffer. It is zeroed after every
; OUTSTR writes the buffer. When a character is DPBed into it, its
; non-zero value serves as an indication that the buffer is nearly full,
; and output is forced. This happens during a call to .TYO, which is
; ultimately responsible for ALL tty output.
; FORCE is called to OUTSTR any characters written by the current high-
; level (undotted) print routine. It forces characters unless (BUFFER T)
; is in effect.
;teletype output
.TTYO: IDPB A,TTYPNT ;OUTPUT SINGLE CHARACTER IN A
SKIPE WARNING ;BUFFER OVERFLOWING?
FORCE: SKIPE OUTCH ;TTY OUTPUT?
POPJ P, ; NO
SKIPN WARNING ;DON'T FORCE YET IF BUFFERING UNLESS
SKIPN BUFFLG ; OVERFLOWN
JRST .+2
POPJ P,
PUSH P,A
MOVEI A, ;MAKE SURE IT'S ASCIZ
IDPB A,TTYPNT
OUTSTR TTYBUF ;TYPE CURRENT BUFFER
FORST1: SETZM WARNING ;NO OVERFLOW NOW
MOVE A,[POINT 7,TTYBUF] ;RESET
MOVEM A,TTYPNT
POP P,A
POPJ P,
FORSET: PUSH P,[0]
SETZM BUFFLG
JRST FORST1
; (BUFFER T) inhibits output until buffer overflow or next (BUFFER NIL).
; (BUFFER NIL) forces waiting output, and allows normal FORCing.
; BUFFER returns previous flag value.
BUFFER: EXCH 1,BUFFLG ;REPLACE AND RETURN
JRST FORCE
BUFFLG: 0 ;IF T, TTY OUTPUT GOES OUT ONLY ON OFLOW
TTYPNT: POINT 7,TTYBUF
TTYBUF: BLOCK ↑D29
WARNING: 0 ;WHEN THIS FILLS, TIME TO DUMP
DDTIFG: FOO TRUTH
DDTIN: EXCH A,DDTIFG
POPJ P,
TTYRET: PUSHJ P,OUTCNT
JRST INCNT
TTOCH: 0 ;*
0 ;tty page number always zero
0 ;tty line number -- always zero
TTOLL: TTYLL ;*
TTOHP: TTYLL ;*
SUBTTL Input and Output Initialization and Control -- SIXMAK, NXTIO, SIXRT
;convert ascii to sixbit for device initialization routines
SIXMAK: PUSH P,C
SETZM SIXMK2#
MOVE AR1,[POINT 6,SIXMK2]
HRROI R,SIXMK1
PUSHJ P,PRINTA ;use print to unpack ascii characters
MOVE A,SIXMK2
POP P,C
POPJ P,
SIXMK1: TRZE A,100 ;COPY 100 BIT TO 40 BIT
TROA A,40
TRZ A,40
TLNN AR1,770000
POPJ P, ;last character position -- ignore remaining chars
CAIN A,'.'
MOVEI A,0 ;ignore dots at end of numbers for decimal base
CAIN A,':'
HRLI AR1,(POINT 6,0,29) ;deposit : in last char position
IDPB A,AR1
POPJ P,
;subroutine to process next item in file name list
INXTIO: JUMPE T,NXTIO
HRRZ T,(T)
NXTIO: HLRZ A,(T)
PUSHJ P,ATOM
JUMPE A,CPOPJ ;non-atomic
HLRZ A,(T)
JRST SIXMAK ;make sixbit if atomic
;right normalize sixbit
LSH A,-6
SIXRT: TRNN A,77
JRST .-2
POPJ P,
;IOSUB, CHNSUB, Channel table definitions.
IOSUB: PUSHJ P,NXTIO
MOVEM T,DEVDAT#
LDB B,[POINT 6,A,35]
JUMPE A,IOPPN ;non-atomic item, must be ppn or (file.ext)
CAIE B,":"-40
JRST IOFIL ;not a device name -- must be file name
TRZ A,77 ;clear out the :
SETZM PPN
IODEV2: MOVEM A,DEV
; USERIO 9-73 DCS-- detect device FN:, set CHNAM entry for channel negative.
; That is the signal for detecting USERIO throughout the other operations.
MOVSI B,400000;device "FN:" means user function does "input"
CAMN A,[SIXBIT /FN/]
HLLM B,CHNAM(C) ;NEGATIVE CHNAM ENTRY FOR FN:
PUSHJ P,INXTIO
IOPPN: JUMPN A,IOFIL ;not ppn or (fil.ext)
PUSHJ P,PPNEXT
JUMPN A,IOEXT ;(fil.ext)
HLRZ A,(T)
HLRZ A,(A) ;caar is project number
PUSHJ P,SIXMAK
PUSHJ P,SIXRT
HRLM A,PPN ;project number
HLRZ A,(T)
PUSHJ P,CADR ;cadar is programmer number
PUSHJ P,SIXMAK
PUSHJ P,SIXRT
HRRM A,PPN ;programmer number
HRLZI A,(SIXBIT /DSK/) ;disk is assumed
JRST IODEV2
IOFIL: SKIPN DEV
JRST AIN.1 ;no device named
JUMPN A,IOFIL2 ;was it an atom
JUMPE T,CPOPJ ;no, was it nil (end)
PUSHJ P,PPNEXT
JUMPE A,CPOPJ ;see a ppn, no file named
IOEXT: HLRZ A,(T) ;(file.ext)
HRRZ A,(A) ;get cdr == extension
PUSHJ P,SIXMAK
HLLM A,EXT
HLRZ A,(T)
HLRZ A,(A) ;get car = file name
PUSHJ P,SIXMAK
FIL: PUSH P,A
PUSHJ P,INXTIO
JRST POPAJ
IOFIL2: CAIN B,":"-40
POPJ P, ;saw a :,not file name
SETZM EXT ;file name -- clear extension
; USERIO 9-73 DCS -- there should always be an atom following FN:. This
; is the USERIO function name.
SKIPGE CHNAM(C);FN: ?
HLRZ A,(T) ; Yes, just return function atom.
JRST FIL
PPNEXT: JUMPE T,CPOPJ ;end of file name list
HLRZ A,(T)
HRRZ A,(A) ;cdar
JRST ATOM ;ppn iff (not(atom(cdar l)))
CHNSUB: MOVE T,A
HLRZ A,(T)
PUSHJ P,ATOM
JUMPE A,TRUE ;non-atomic head of list -- no channel named
HLRZ A,(T)
PUSHJ P,SIXMAK
ANDI A,77
CAIN A,":"-40
JRST TRUE ;device name, assume channel name t
HLRZ A,(T) ;channel name -- return it
HRRZ T,(T)
POPJ P,
CHTAB=.-FSTCH
BLOCK NIOCH ;*
;channel data
CHNAM==0 ;name of channel I/O
; USERIO 9-73 DCS -- LH negative (400000) for USERIO channel.
CHDEV==1 ;name of device I/O
CHPPN==2 ;ppn for input channel I/
CHLL==2 ;linelength for output channel /O
CHOCH==3 ;oldch for input channels I/
CHHP==3 ;hposit for output channels /O
CHPAGE==4 ;page number for input I/
INCHAN==4 ;input buffer info pointer for update /O
CHLINE==5 ;line number for input
; RANDOM 8-73 DCS
CHREC==6 ;record number for USETI/USETO
CHDAT==7 ;device data
; USERIO 9-73 DCS
FNNAME==7 ;function name, for functionally simulated input (FN:)
POINTR==10 ;byte pointer for device buffer
COUNT==11 ;character count for device buffer
; DCS 8-73 RANDOM -- INOUT channel table entries look mostly like
; OUTPUT channel entries. The exception is that the INCHAN
; (a new) entry is non-null for INOUT. It is a pointer to
; the channel table entry for the corresponding input side
; of the channel. The stored names are related in the usual
; way, with the output file name 400000 greater than the
; input name. Special code in TTY input EOF, (INC ... T),
; and (OUTC ... T) take care of releasing both blocks, the
; latter to a special list of INOUT input blocks.
; Additionally, code in INPUT, OUTPUT, and support routines were
; changed to accommodate calls from INOUT, to set up this beast.
; A much cleaner design would result from a rewrite of the whole
; section.
;TABSRC, TABSR1, IOBRST (NEEDMR, DEVCLR)
;search for channel name in chtab
TABSR1: MOVE A,[XWD -NIOCH,FSTCH]
PUSH P,AR1
MOVE C,CHTAB(A)
HRRZ AR1,CHNAM(C)
CAME B,AR1
AOBJN A,.-3
CAME B,AR1
MOVEI A,NIL ;DIDN'T FIND, NIL
POP P,AR1
POPJ P,
;search for channel name in chtab, and if not there find a free channel, and
;if no free channel, allocate a new buffer and channel
TABSRC: MOVE B,A
PUSHJ P,TABSR1
JUMPN A,DEVCLR ;found the channel
PUSH P,B
HRRZ B,NIL
PUSHJ P,TABSR1 ;find a physical channel no. for a free channel
JUMPE A,[ERR1 [SIXBIT $NO I/O CHANNELS LEFT !$]]
POP P,B
JUMPN C,DEVCLR ;found free channel which had buffer space previously
; DCS 8-73 RANDOM -- NEEDMR label added, called from INOUT.
NEEDMR: PUSH P,A ;must allocate new buffer
MOVEI A,BLKSIZ
PUSHJ P,MORCOR ;expand core for buffer if necessary
MOVE C,A
POP P,A
; DCS 8-73 RANDOM -- DEVCL1 label added, called from RANDOM code.
DEVCL1: HRRM C,CHTAB(A)
DEVCLR: HRRZ C,CHTAB(A)
HRRZM B,CHNAM(C) ;store name
HRRZM A,CHANNEL#
POPJ P,
;subroutine to reset all i/o channels -- used by excise and realloc
IOBRST: X ;jsr location
HRRZ A,JOBREL
HRLM A,JOBSA
MOVEM A,CORUSE#
MOVEM A,JOBSYM
SETZM LDFLG ;NO SYMBOLS LOADED
SETZM CHTAB+FSTCH
MOVE A,[XWD CHTAB+FSTCH,CHTAB+FSTCH+1]
BLT A,CHTAB+NIOCH+FSTCH-1 ;clear channel table
JRST @IOBRST
;INPUT
INPUT: PUSHJ P,CHNSUB ;determine channel name
PUSH P,A
PUSHJ P,TABSRC ;get physical channel number, allocate buffer
PUSHJ P,SETIN ;init device
JRST POPAJ
SETIN: MOVEM A,CHANNEL
MOVE A,CHDEV(C)
MOVEM A,DEV
MOVE A,CHPPN(C)
MOVEM A,PPN
PUSHJ P,IOSUB ;get device and file name
MOVEM A,LOOKIN ;file name
; DCS USERIO 9-73 -- record "file name" -- which is, in this case just
; an atom -- in the data for the "file", for user i/o channels. This
; will be wiped out in the INBUF, for non-USERIO channels (device not FN:).
SKIPL CHNAM(C) ;!!!
MOVEI A,0 ;!!!
MOVEM A,CHDAT(C);!!!
MOVE A,CHANNEL
HRLM T,CHTAB(A) ;save remaining file name list
DPB A,[POINT 4,ININIT,ACFLD] ;set up channel numbers
DPB A,[POINT 4,INLOOK,ACFLD]
DPB A,[POINT 4,ININBF,ACFLD]
MOVEI A,CHDAT(C)
; DCS 8-73 RANDOM -- lh may contain ptr. from prev. operation for INOUT files.
HRRM A,DEV+1 ;was MOVEM -- DCS
PUSH C,DEV
PUSH C,PPN
PUSH C,[0] ;oldch
PUSH C,[0] ;page number
PUSH C,[0] ;line number
PUSH C,[0] ;record number
ADDI C,4 ;COUNT+1 words, in all
HRRM C,JOBFF
; DCS 9-73 USERIO -- above and below re-arranged so that USERIO channels do
; not need to do INIT's, LOOKUP's, INBUF's, etc.
SKIPGE CHNAM-COUNT-1(C);FN: device?
JRST TRUE ; yes, all done
MOVE A,DEV
CALLI A,DEVCHR
TLNN A,INB
JRST AIN.2 ;not input device
TLNN A,AVLB
JRST AIN.4 ;not available
ININIT: INIT X,
DEV: X
X
JRST AIN.7 ;cant init
INLOOK: LOOKUP X,LOOKIN
JRST AIN.7 ;cant find file
MOVE A,CHPPN-COUNT-1(C);DCS 8-73 RANDOM -- Restore PPN for subsequent
MOVEM A,PPN ; ENTER if INOUT.
ININBF: INBUF X,NIOB
JRST TRUE
ENTR:
LOOKIN: BLOCK 4
EXT=LOOKIN+1
PPN=LOOKIN+3
;OUTPUT
OUTPUT: PUSHJ P,CHNSUB ;get channel name
PUSH P,A
TRO A,400000 ;set bit for output
PUSHJ P,TABSRC ;get physical channel nuber
PUSHJ P,IOSUB ;get device and file name
MOVEM A,ENTR ;file name
; DCS USERIO 9-73 -- record "file name" -- which is, in this case just
; an atom -- in the data for the "file", for user i/o channels. This
; will be wiped out in the OUTBUF, for non-USERIO channels (device not FN:).
SKIPL CHNAM(C) ;!!!
MOVEI A,0 ;!!!
MOVEM A,CHDAT(C);!!! if FN: device
SETZM ENTR+2 ;zero creation date
MOVE A,CHANNEL
DPB A,[POINT 4,AOUT2,ACFLD] ;setup channel numbers
DPB A,[POINT 4,OUTENT,ACFLD]
DPB A,[POINT 4,OUTOBF,ACFLD]
MOVEI A,CHDAT(C)
HRLM A,AOUT3+1
; DCS USERIO 9-73 -- above and below reorganized, tests inserted to avoid
; INIT, ENTER, OUTBUF for USERIO channels.
SKIPGE CHNAM(C)
JRST OUTP1
MOVE A,DEV
MOVEM A,AOUT3
CALLI A,DEVCHR
TLNN A,OUTB
JRST AOUT.2 ;not output device
TLNN A,AVLB
JRST AOUT.4 ;not available
AOUT2: INIT X,
AOUT3: X
X
JRST AOUT.4 ;cant init
; DCS 8-73 RANDOM -- In A, for INOUT, is input file BUFDAT pointer
OUTP1: MOVEI A,0 ;no update
INOENT: PUSH C,DEV
PUSH C,[LPTLL] ;linelength
PUSH C,[LPTLL]
PUSH C,A ;DCS 8-73 RANDOM -- potential input bfr. ptr.
PUSH C,[0] ; ?
PUSH C,[0] ;RECORD #, FOR USETI/USETO
ADDI C,4 ;DCS 8-73 RANDOM
HRRM C,JOBFF
SKIPGE CHNAM-COUNT-1(C);DONE, IF "FN:"
JRST POPAJ
OUTENT: ENTER X,ENTR
JRST OUTERR ;cant enter
OUTOBF: OUTBUF X,NIOB
JRST POPAJ
OUTERR: PUSHJ P,AIOP
LDB A,[POINT 3,ENTR+1,35]
CAIE A,2
ERR1 [SIXBIT /DIRECTORY FULL !/]
ERR1 [SIXBIT /FILE IS WRITE PROTECTED !/]
;INOUT
; DCS 8-73 RANDOM -- New routines: INOUT, USETI, USETO
INOUT:
FOO SKIPN B,SAVIOB ;First get a buffer for the output
JRST [PUSH P,A ; part, either from a list of same,
MOVEI A,BLKSIZ ; or from new core -- this will
PUSHJ P,MORCOR ; replace the input core obtained
MOVE C,A ; from INPUT below, and the latter's
EXCH A,(P) ; buffer will be stored back in
JRST INOUT1] ; SAVIOB list later.
HLRZ C,(B) ;There were some: CDR the list, and
HRRZ B,(B) ; take the CAR.
FOO MOVEM B,SAVIOB
PUSH P,C ;Save output buffer and data block
INOUT1: MOVEI B,CHDAT(C) ;Prepare buffer header (output) for
HRLM B,DEV+1 ; INPUT's INIT, then do
PUSHJ P,INPUT ; (INPUT CHANNEL FILE)
SETZM DEV+1 ; (NEXT INPUT FUNNY ELSE)
PUSH P,A ;FINAL result, for later
MOVE A,CHANNEL ;Now set ENTER and OUTBUF instrs
DPB A,[POINT 4,OUTENT,ACFLD]
DPB A,[POINT 4,OUTOBF,ACFLD]
MOVE T,CHTAB(A) ;The INPUT buffer and data block,
TLNE T,-1 ; verify that there's but one file.
JRST [ERR1 [SIXBIT /CAN ONLY UPDATE ONE FILE!/]]
MOVE B,CHNAM(T) ;Now set up to fill previously
TRO B,400000 ; obtained output data block
MOVE C,-1(P) ;This is it
PUSHJ P,DEVCL1 ;Set name in block, set CHTAB ent.
DOENT: MOVE A,T ;A is input buffer pointer.
POP P,-1(P) ;Zap the old saved buffer ptr.
JRST INOENT ;Finish setting up output, store
; A somewhere in B.
;USETI, USETO, CHSETI, CHSETO
USETI: PUSHJ P,INISET
INFTST: JUMPE T,FIX1A
JUMPL T,[ERR1 [SIXBIT /NON-NUMERIC ARGUMENT -- USETX !/]]
PUSHJ P,INPTST
RESREC: HRRM T,CHREC(C)
JRST FIX1A
USETO: PUSHJ P,INISET
JUMPE T,FIX1A
PUSHJ P,OPTST1
JUMPG T,SETO
.UGETF: UGETF X,T
PUSHJ P,OPTST1
JRST RESREC
SETO: PUSHJ P,OPTST2
JRST RESREC
CHSETI: PUSHJ P,INISET
PUSHJ P,CALCHR
JUMPLE T,INFTST
PUSHJ P,INPTST
CHRQUT: MOVNM TT,COUNT(AR1)
ADDM AR2A,POINTR(AR1)
JRST RESREC
CHSETO: PUSHJ P,INISET
MOVE AR1,C
PUSHJ P,CALCHR
JUMPLE T,INFTST
PUSHJ P,OPTST1
HRRZ AR1,INCHAN(C)
JUMPE AR1,NSETIN
PUSHJ P,INPTS1
TRNE B,20000
MOVEI AR1,0
NSETIN: PUSHJ P,OPTST2
JUMPE AR1,CHOQUT
HRRZ B,CHDAT(C)
HRL B,CHDAT(AR1)
ADD B,[2,,2]
HRRZ AR1,B
BLT B,177(AR1)
CHOQUT: MOVE AR1,C
JRST CHRQUT
INISET: PUSH P,A
MOVE A,B
JUMPE A,INFNLY
FOO CAIN A,TRUTH
MOVEI A,INUM0-1
PUSHJ P,NUMVAL
INFNLY: MOVE T,A
MOVEI TT,
POP P,B
PUSHJ P,TABSR1
JUMPN A,GTCN
TRO B,400000
PUSHJ P,TABSR1
JUMPE A,[ERR1 [SIXBIT /NON-EXISTENT CHANNEL -- USETX !/]]
GTCN: DPB A,[POINT 4,.USETI,12]
DPB A,[POINT 4,.USETO,12]
DPB A,[POINT 4,.UGETF,12]
DPB A,[POINT 4,.OUTPUT,12]
DPB A,[POINT 4,.INPUT,12]
DPB A,[POINT 4,.GETSTS,12]
MOVE A,CHREC(C)
TRNN B,400000
JRST RETC
HRRZ AR1,INCHAN(C)
JUMPN AR1,CPOPJ
RETC: MOVE AR1,C
POPJ P,
CALCHR: SKIPN B,COUNT(AR1)
MOVEI B,1
IMULI A,200*5
SUBI A,-2(B)
JUMPLE T,CPOPJ
ADDI T,<200*5>-1
IDIVI T,200*5
PUSH P,AR2A+1
MOVEI AR2A,4(TT)
IDIVI AR2A,5
HLL AR2A,[POINT 0,0,6
POINT 0,0,13
POINT 0,0,20
POINT 0,0,27
POINT 0,0,34](AR2A+1)
POP P,AR2A+1
SUBI TT,<200*5>+1
POPJ P,
INPTST: CAME AR1,C
PUSHJ P,OPTST1
INPTS1:
.USETI: USETI X,(T)
MOVEI B,
.INPUT: IN X,
JRST [AOS COUNT(AR1)
POPJ P,]
.GETSTS:GETSTS X,B
TRNE B,740000
ERR1 [SIXBIT /INPUT ERROR -- USETI !/]
POPJ P,
OPTST2:
.USETO: USETO X,(T)
OPTST1:
.OUTPUT:OUT X,
SKIPA
ERR1 [SIXBIT /OUTPUT ERROR -- USETO !/]
AOS COUNT(C)
POPJ P,
IOSEL: MOVE C,-1(P)
JUMPE C,CPOPJ ;tty
JUMPE B,IOSELZ ;dont release
DPB C,[POINT 4,.+1,ACFLD]
RELEASE X, ;release channel
; DCS 8-73 RANDOM -- Replaces HRRZS CHTAB(C) ... Release both
; input and output sides of old CHANNEL, if flag is T
PUSH P,A ;Now, if the file being released is
PUSH P,B
HRRZS A,CHTAB(C) ; an update file, CONS the input
MOVE B,CHNAM(A)
TRNN B,400000
JRST NOUPD
HRRZ A,INCHAN(A) ; buffer pointer onto the free
JUMPE A,NOUPD ; input-for-update buffer list
FOO MOVE B,SAVIOB
PUSHJ P,CONS
FOO MOVEM A,SAVIOB
NOUPD: POP P,B
POP P,A
;See HRRZS above, remaining input flushed
MOVEM 0,@CHTAB(C) ;blast channel name
SETZM -1(P)
IOSELZ: HRRZ C,CHTAB(C)
POPJ P,
INCNT: MOVEI A,NIL ;(INC NIL T)
FOO MOVEI B,TRUTH
INC: PUSH P,INCH#
PUSHJ P,IOSEL
JUMPN B,INC2 ;released channel
SKIPN C
MOVEI C,TTOCH-CHOCH ;tty deselect
MOVEI B,CHOCH(C)
HRLI B,OLDCH
BLT B,CHLINE(C) ;save channel data
INC2: JUMPE A,ITTYRE ;select tty
MOVE B,A
PUSHJ P,TABSR1 ;determine physical channel number
; DCS 8-73 RANDOM -- if can't find as input file, maybe can find,
; disguised under output file, as INOUT file.
JUMPE A,[TRO B,400000 ;Didn't find it as input file, perhaps
PUSHJ P,TABSR1 ; it's an update file, in which case
JUMPE A,[ERR1 [SIXBIT/NO INPUT - INC!/]]
HRRZ C,INCHAN(C); the input pointer would be in INCHAN
JUMPE C,[ERR1 [SIXBIT/NO INPUT - INC!/]]
JRST DEPINC] ; of the output buffer representing chan.
DEPINC: HRRZM A,INCH
DPB A,[POINT 4,TYI2X,ACFLD] ;set up channel numbers
DPB A,[POINT 4,TYI2Y,ACFLD]
DPB A,[POINT 4,TYI2Z,ACFLD]
MOVEI T,COUNT(C)
HRLI T,(SOSG)
; DCS USERIO 9-73 -- interface to TYIFN code for each TYI -- from there
; control will transfer to user routine.
SKIPGE CHNAM(C) ;FN: DEVICE?
MOVE T,[JRST TYIFN+X]
MOVEI B,POINTR(C)
HRRM B,TYI3 ;set up tyi parameters
HRRM B,TYI3A
INC3: MOVSI B,CHOCH(C)
HRRI B,OLDCH
BLT B,LINUM ;restore channel data
MOVEM T,TYID
; DCS USERIO 9-73 -- if a USERIO channel, the transfer to IOFN will put the
; user routine name there. Otherwise, it will transfer garbage, but no-one
; will look there, so that's all right.
IOEND: MOVE C,FNNAME(C)
MOVEM C,IOFN#
POP P,A
JUMPE A,CPOPJ
MOVE A,CHTAB(A) ;get channel name
HRRZ A,CHNAM(A)
TRZ A,400000 ;clear output bit
POPJ P,
ITTYRE: SETZM INCH
MOVE T,[JRST TTYI] ;reselect tty
MOVEI C,TTOCH-CHOCH
JRST INC3
OUTCNT: MOVEI A,0 ;(outc nil t)
MOVEI B,1
OUTC: PUSH P,OUTCH#
PUSHJ P,IOSEL
JUMPN B,OUTC2 ;closed this file
SKIPN C
MOVEI C,TTOLL-CHLL ;tty deselect
MOVE B,CHCT
MOVEM B,CHHP(C) ;save channel data
MOVE B,LINL
MOVEM B,CHLL(C)
OUTC2: JUMPE A,OTTYRE ;return to tty
TRO A,400000 ;set output bit
MOVE B,A
PUSHJ P,TABSR1 ;determine physical channel number
JUMPE A,[ERR1 [SIXBIT /NO OUTPUT - OUTC!/]]
DPB A,[POINT 4,TYO2X,ACFLD] ;set up tyo2 channel numbers
HRRZM A,OUTCH
MOVEI B,POINTR(C)
HRRM B,TYO5 ;set up tyo2 parameters
MOVEI T,COUNT(C)
HRLI T,(SOSG)
; DCS USERIO 9-73 -- interface to TYOFN for user TYO output.
SKIPGE CHNAM(C)
MOVE T,[JRST TYOFN+X]
OUTC3: MOVE B,CHLL(C)
MOVEM B,LINL
MOVE B,CHHP(C)
MOVEM B,CHCT
MOVEM T,.TYOD
JRST IOEND
OTTYRE: SETZM OUTCH
MOVE T,[JRST .TTYO]
MOVEI C,TTOLL-CHLL ;tty reselect
JRST OUTC3
AIN.1: PUSHJ P,AIOP
ERR1 [SIXBIT $ILLEGAL I/O ARG!$]
AOUT.2:
AIN.2: PUSHJ P,AIOP
ERR1 [SIXBIT /ILLEGAL DEVICE!/]
AOUT.4:
AIN.4: PUSHJ P,AIOP
ERR1 [SIXBIT /DEVICE NOT AVAILABLE !/]
AIN.7: PUSHJ P,AIOP
ERR1 [SIXBIT /CAN'T FIND FILE - INPUT!/]
AIN.8: SIXBIT /INPUT ERROR!/
AIOP: MOVE A,DEVDAT
JRST EPRINT
SUBTTL PRINT --- PAGE 8
EPRINT: SKIPN ERRSW
POPJ P,
PUSHJ P,ERRIO
PUSHJ P,PRINT
JRST OUTRET
PRINT: MOVEI R,.TYO
PUSHJ P,.TERPRI
PUSHJ P,.PRIN1
XCT " ",CTY
JRST FORCE
; REAL WORK DONE BY .ROUT ROUTINES, WHICH DO NOT FORCE TTY OUTPUT.
; THESE ARE CALLED DIRECTLY BY USER, FORCE PRINTOUT ON COMPLETION.
PRINC: PUSHJ P,.PRINC ;Print one S-expr, slashified.
JRST FORCE
PRIN1: PUSHJ P,.PRIN1 ;Print one S-expr, unslashified.
JRST FORCE
TYO: PUSHJ P,.TYO ;Print one character, right now.
JRST FORCE
TTYO: PUSHJ P,.TTYO ;Type one character, right now.
JRST FORCE
TYOD: PUSHJ P,.TYOD
JRST FORCE
TERPRI: PUSHJ P,.TERPRI
JRST FORCE
.PRINC: SKIPA R,.+1
.PRIN1: HRRZI R,.TYO
PUSH P,A
PUSHJ P,PRINTA
JRST POPAJ
PRINTA: PUSH P,A
MOVEI B,PRIN3
SKIPGE R
MOVEI B,PRIN4
HRRM B,PRIN5
PUSHJ P,PATOM
JUMPN A,PRINT1
XCT "(",CTY
PRINT3: HLRZ A,@(P)
PUSHJ P,PRINTA
HRRZ A,@(P)
JUMPE A,PRINT2
MOVEM A,(P)
XCT " ",CTY
PUSHJ P,PATOM
JUMPE A,PRINT3
XCT ".",CTY
XCT " ",CTY
PUSHJ P,PRIN1A
PRINT2: XCT ")",CTY
JRST POPAJ
PRINT1: PUSHJ P,PRIN1A
JRST POPAJ
PRIN1A: MOVE A,-1(P)
CAILE A,INUMIN
JRST PRINIC
JUMPE A,PRIN1B
CAIGE A,@GCP1
CAIGE A,@GCPP1
JRST PRINL
PRIN1B: HRRZ A,(A)
JUMPE A,PRINL
HLRZ B,(A)
HRRZ A,(A)
FOO CAIN B,PNAME
JRST PRINN
FOO CAIN B,FIXNUM
JRST PRINI1
FOO CAIN B,FLONUM
JRST PRINO
BPR: JRST PRIN1B ;bignums change here to JRST BPRINT
JRST PRIN1B
PRINL2: MOVEI R,.TYO
PUSHJ P,PRINL1
JRST FORCE
PRINL: XCT "#",CTY
HRRZ A,-1(P)
PRINL1: MOVEI C,8
JRST PRINI3
PRINI1: SKIPA A,(A)
PRINIC: SUBI A,INUM0
FOO HRRZ C,VBASE
SUBI C,INUM0
JUMPGE A,PRINI2
XCT "-",CTY
MOVNS A
PRINI2: MOVEI B,"."-"0"
HRLM B,(P)
CAIN C,TEN
FOO SKIPE %NOPOINT
JRST .+2
PUSH P,PRINI4
PRINI3: JUMPL A,[ MOVEI B,0 ;case of -2↑35
MOVEI A,1
DIVI A,(C)
JRST .+2]
IDIVI A,0(C)
HRLM B,(P)
SKIPE A
PUSHJ P,.-3
PRINI4: JRST FP7A1
PRINN: HLRZ A,(A)
MOVEI C,2(SP)
PUSHJ P,PNAMU3
PUSH C,[0]
HRLI C,(POINT 7,0,35)
HRRI C,2(SP)
ILDB A,C
JUMPE A,CPOPJ ;special case of null character
CAIN A,DBLQT
JRST PSTR ;string
PRIN2X: LDB B,[POINT 1,CHRTAB(A),1]
JUMPL R,PRIN4 ;never slash
JRST PRIN2(B) ;1 for no slash
PRIN3: SKIPL CHRTAB(A) ;<0 for no slash
PRIN2: XCT "/",CTY
PRIN4: PUSHJ P,(R)
ILDB A,C
PRIN5: JUMPN A,PRIN3 ;prin4 for never slash
POPJ P,
PSTR: MOVS B,(C)
CAIN B,(<ASCII /"/>)
JRST PRIN2X ;special case of /"
PSTR3: SKIPL R ;dont print " if no slashify
PSTR2: PUSHJ P,(R)
ILDB A,C
CAIE A,DBLQT
JUMPN A,PSTR2
JUMPN A,PSTR3
POPJ P,
.TERPRI:PUSH P,A
MOVEI A,CR
PUSHJ P,.TYO
MOVEI A,LF
PUSHJ P,.TYO
JRST POPAJ
CTY: JSA A,TYOI
TYOI: X
PUSH P,A
LDB A,[POINT 6,-1(A),ACFLD]
PUSHJ P,(R)
POP P,A
JRA A,(A)
PRINO: MOVE A,(A)
CLEARB B,C
JUMPG A,FP1
JUMPE A,FP3
MOVNS A
XCT "-",CTY
FP1: CAMGE A,FT01
JRST FP4
CAML A,FT8
AOJA B,FP4
FP3: MULI A,400
ASHC B,-243(A)
MOVE A,B
CLEARM FPTEM#
PUSHJ P,FP7
XCT ".",CTY
MOVNI T,8
ADD T,FPTEM
MOVE B,C
FP3A: MOVE A,B
MULI A,TEN
PUSHJ P,FP7B
SKIPE B
AOJL T,FP3A
POPJ P,
FP4: MOVNI C,6
MOVEI TT,0
FP4A: ADDI TT,1(TT)
XCT FCP(B)
TRZA TT,1
FMPR A,@FCP+1(B)
AOJN C,FP4A
PUSH P,TT
MOVNI B,-2(B)
DPB B,[POINT 2,FP4C,11]
PUSHJ P,FP3
MOVEI A,"E"
PUSHJ P,(R)
FP4C: XCT "+"+X,CTY
POP P,A
FP7: JUMPE A,FP7B
IDIVI A,TEN
AOS FPTEM
HRLM B,(P)
JUMPE A,FP7A1
PUSHJ P,FP7
FP7A1: HLRE A,(P)
FP7B: ADDI A,"0"
JRST (R)
353473426555 ;1e32
266434157116 ;1e16
FT8: 1.0E8
1.0E4
1.0E2
1.0E1
FT: 1.0E0
026637304365 ;1e-32
113715126246 ;1e-16
146527461671 ;1e-8
163643334273 ;1e-4
172507534122 ;1e-2
FT01: 175631463146 ;1e-1
FT0:
FCP: CAMLE A,FT0(C)
CAMGE A,FT(C)
XWD C,FT0
SUBTTL SUPER FAST TABLE DRIVEN READ 14-MAY-69 PAGE 9
;magic scanner table bit definitions
;bit 0=0 iff slashified as 1st id character
;bit 1=0 iff slashified as nth id character
;bits 2-5 ratab index
;bits 6-8 dotab index
;bits 9-10 strtab index
;bits 11-13 idtab index
;bits 14-16 exptab index
;bits 17-19 rdtab index
;bits 20-25 ascii to radix 50 conversion
IGSTRT: IGCRLF
IGEND: LF
RATFLD: POINT 4,CHRTAB(A),5
STRFLD: POINT 2,CHRTAB(A),10
IDFLD: POINT 3,CHRTAB(A),13
DOTFLD:
NUMFLD: POINT 3,CHRTAB(A),8
EXPFLD: POINT 3,CHRTAB(A),16
RDFLD: POINT 3,CHRTAB(A),19
R50FLD: POINT 6,CHRTAB(A),25
;magic state flags in t
EXP==1 ;exponent
NEXP==2 ;negative exponent
SAWDOT==4 ;saw a dot (.)
MINSGN==10 ;negative number
IDCLS==0 ;identifier
STRCLS==1 ;string
NUMCLS==2 ;number
DELCLS==3 ;delimiter
;macros for scanner table
DEFINE RAD50 (X)<
IFB <X>,<R50VAL=0>
IFLE <"X"-"9">,<IFGE <"X"-"0">,<R50VAL="X"-"0"+1>>
IFIDN <"X"><".">,<R50VAL=45>
IFGE <"X"-"A">,<R50VAL="X"-"A"+13>>
DEFINE TABIN (S1,SN,R,D,S,I,E,RD,R50)<
XLIST
IRPC R50< RAD50 (R50)
BYTE (1)S1,SN(4)R(3)D(2)S(3)I,E,RD(6)R50VAL>
LIST>
DEFINE LET (X)<
TABIN (1,1,5,2,3,4,2,0,X)>
DEFINE DELIMIT (X,Y)<
TABIN (0,0,2,2,3,2,2,Y,X)>
DEFINE IGNORE (X)<
TABIN (0,0,3,2,3,2,2,0,X)>
CHRTAB:
TABIN (0,0,1,1,1,1,1,0,< >)
;null
LET (< >)
IGNORE (< >)
;tab,lf,vtab,ff,cr
LET (< >)
;16 to 31
TABIN (0,0,0,0,0,0,0,0,< >)
;igmrk
LET (< >)
;33 to 37
IGNORE (< >)
;space
LET (< >)
;!
TABIN (0,0,9,2,2,2,2,0,< >)
;"
LET (< $% >)
;#$%&'
DELIMIT (< >,0)
DELIMIT (< >,1)
;()
LET (< >)
;*
TABIN (1,0,3,2,3,4,2,0,< >)
;+
IGNORE (< >)
;,
TABIN (1,0,6,2,3,4,2,0,< >)
;-
TABIN (0,0,7,3,3,2,2,4,<.>)
TABIN (0,0,4,2,3,3,2,0,< >)
;/
TABIN (1,0,8,5,3,4,3,0,<0123456789>)
LET (< >)
;:;<=>?
TABIN (1,0,2,2,3,4,2,5,< >)
;@
LET (<ABCD>)
TABIN (1,1,5,4,3,4,2,0,<E>)
LET (<FGHIJKLMNOPQRSTUVWXYZ>)
DELIMIT (< >,2)
;[
LET (< >)
;\
DELIMIT (< >,3)
;]
LET (< >)
;↑←`
LET (<ABCDEFGHIJKLMNOPQRSTUVWXYZ>)
;lower case
LET (< >)
;{¬
DELIMIT (< >,3)
;altmode
LET (< >)
;}
DELIMIT (< >,6)
;rubout
READCH: PUSHJ P,TYI
MOVSI AR1,AR1
PUSHJ P,EXPL1
JRST CAR
READP1: SETZM NOINFG
READ0: PUSH P,TYID
PUSH P,OLDCH
SETZM OLDCH#
HRLI A,(JRST)
MOVEM A,TYID
PUSHJ P,READ+1
POP P,OLDCH
POP P,TYID
POPJ P,
RDRUB: MOVEI A,CR
PUSHJ P,.TTYO
MOVEI A,LF
PUSHJ P,.TTYO
SKIPA P,PSAV#
READ: SETZM NOINFG# ;0 means intern
MOVEM P,PSAV
PUSHJ P,READ1
SETZM PSAV
POPJ P,
READ1: PUSHJ P,RATOM
POPJ P, ;atom
XCT RDTAB2(B)
JRST READ1 ;try again
RDTAB2: JRST READ2 ;0 (
JFCL ;1 )
JRST READ4 ;2 [
JFCL ;3 ],$
JFCL ;4 .
JRST RDQT ;5 @
READ2: PUSHJ P,RATOM
JRST READ2A ;atom
XCT RDTAB(B)
READ2A: PUSH P,A
PUSHJ P,READ2
POP P,B
JRST XCONS
RDTAB: PUSHJ P,READ2 ;0 (
JRST FALSE ;1 )
PUSHJ P,READ4 ;2 [
JRST READ5 ;3 ],$
JRST RDT ;4 .
PUSHJ P,RDQT ;5 @
RDTX: PUSHJ P,RATOM
POPJ P, ;atom
XCT RDTAB2(B)
JRST DOTERR ;dot context error
RDT: PUSHJ P,RDTX
PUSH P,A
PUSHJ P,RATOM
JRST DOTERR
CAIN B,1
JRST POPAJ
CAIE B,3
JRST DOTERR
MOVEM A,OLDCH
JRST POPAJ
READ4: PUSHJ P,READ2
MOVE B,OLDCH
CAIE B,ALTMOD
TYI1: SETZM OLDCH ;kill the ]
POPJ P,
READ5: MOVEM A,OLDCH ;save ] or $
JRST FALSE ;and return nil
RDQT: PUSHJ P,READ1
JRST QTIFY
;atom parser
COMMENT: PUSHJ P,TYID
CAME A,IGEND
JRST COMMENT
POPJ P,
RATOM: SETZB T,R
HRLI C,(POINT 7,0,35)
HRRI C,(SP)
MOVEI AR1,1
RATOM2: PUSHJ P,TYIA
LDB B,RATFLD
JRST RATAB(B)
RATAB: PUSHJ P,COMMENT ;0 comment
JRST RATOM2 ;1 null
JRST RATOM3 ;2 delimit
JRST RATOM2 ;3 ignore
PUSHJ P,TYI ;4 /
JRST RDID ;5 letter
JRST RDNMIN ;6 -
JRST RDOT ;7 .
JRST RDNUM ;8 digit
JRST RDSTR ;9 string
;a real dotted pair
RDOT2: MOVEM A,OLDCH
MOVEI A,"."
RATOM3: LDB B,RDFLD
HRRI R,DELCLS ;delimiter
AOS (P) ;non-atom (ie a delimiter)
POPJ P,
;dot handler
RDOT: PUSHJ P,TYID
LDB B,DOTFLD
JRST DOTAB(B)
DOTAB: PUSHJ P,COMMENT ;0 comment
JRST RDOT ;1 null
JRST RDOT2 ;2 delimit
JRST RDOT2 ;3 dot
JRST RDOT2 ;4 e
MOVEI B,0 ;5 digit
IDPB B,C
TLO T,SAWDOT
JRST RDNUM
;string scanner
STRTAB: PUSHJ P,COMMENT ;0 comment
JRST RDSTR+1 ;1 null
JRST STR2 ;2 delimit
RDSTR: IDPB A,C ;3 string element
PUSHJ P,TYID
LDB B,STRFLD
JRST STRTAB(B)
STR2: MOVEI A,DBLQT
HRRI R,STRCLS ;string
IDPB A,C
NOINTR: PUSHJ P,IDEND ;no intern
PUSHJ P,IDSUB
JRST PNAMAK
;identifier scanner
IDTAB: PUSHJ P,COMMENT ;0
JRST RDID+1 ;1 null
JRST MAKID ;2 delimit
PUSHJ P,TYI ;3 /
RDID: IDPB A,C ;4 letter or digit
PUSHJ P,TYID
LDB B,IDFLD
JRST IDTAB(B)
;number scanner
NUMTAB: PUSHJ P,COMMENT ;0 comment
JRST RDNUM+1 ;1 null
JRST NUMAK ;2 delimit
JRST RDNDOT ;3 dot
JRST RDE ;4 e
RDNUM: IDPB A,C ;5 digit
PUSHJ P,TYID
LDB B,NUMFLD
JRST NUMTAB(B)
RDNDOT: TLOE T,SAWDOT
JRST NUMAK ;two dots - delimit
MOVEI A,0
JRST RDNUM
RDNMIN: TLO T,MINSGN
JRST RDNUM+1
;exponent scanner
RDE: TLO T,EXP
MOVEI A,0
IDPB A,C
PUSHJ P,TYID
CAIN A,"-"
TLOA T,NEXP
CAIN A,"+"
JRST RDE2+1
JRST RDE2+2
EXPTAB: PUSHJ P,COMMENT ;0
JRST RDE2+1 ;1 null
JRST NUMAK ;2 delimit
RDE2: IDPB A,C ;3 digit
PUSHJ P,TYID
LDB B,EXPFLD
JRST EXPTAB(B)
;semantic routines
;identifier interner and builder
IDEND: TDZA A,A
IDEND1: IDPB A,C
TLNE C,760000
JRST IDEND1
POPJ P,
MAKID: MOVEM A,OLDCH
PUSHJ P,IDEND
SKIPE NOINFG
JRST NOINTR ;dont intern it
INTER0: PUSHJ P,IDSUB
PUSHJ P,INTER1 ;is it in oblist
POPJ P, ;found
PUSHJ P,PNAMAK ;not there
MAKID2: MOVE C,CURBUC ;
HLRZ B,@RHX2
PUSHJ P,CONS ;cons it into the oblist
HRLM A,@RHX2
JRST CAR
CURBUC: 0
;pname unmaker
PNAMUK:
FOO MOVEI B,PNAME
PUSHJ P,GET
JUMPE A,NOPNAM
MOVE C,SP
PNAMU3: HLRZ B,(A)
PUSH C,(B)
HRRZ A,(A)
JUMPN A,PNAMU3
POPJ P,
;idsub constructs a iowd pointer for a print name
IDSUB: HRRZS C
CAML C,JRELO ;top of spec pdl
JRST SPDLOV
MOVNS C
ADDI C,(SP)
HRLI C,1(SP)
MOVSM C,IDPTR#
POPJ P,
PAGE ;identifier interner
INTER1: MOVE B,1(SP) ;get first word of pname
LSH B,-1 ;right justify it
INT1: IDIVI B,BCKETS+X ;compute hash code
RHX2:
FOO HLRZ TT,OBTBL(B+1) ;get bucket
MOVEM B+1,CURBUC ;save bucket number
MOVE T,TT
JRST MAKID1
MAKID3: MOVE TT,T ;save previous atom
HRRZ T,(T) ;get next atom
MAKID1: JUMPE T,CPOPJ1 ;not in oblist
HLRZ A,(T) ;next id in oblist
MAKID4: HRRZ A,(A)
JUMPE A,NOPNAM ;no print name
MOVE A,(A)
HLRZ C,A
FOO CAIE C,PNAME
JRST MAKID4
MOVE C,IDPTR ;found pname
HLRZ A,(A)
MAKID5: JUMPE A,MAKID3 ;not the one
MOVS A,(A)
MOVE B,(A)
ANDCAM AR1,(C) ;clear low bit
CAME B,(C)
JRST MAKID3 ;not the one
HLRZ A,A ;ok so far
AOBJN C,MAKID5
JUMPN A,MAKID3 ;not the one
HLRZ A,(T) ;this is it
HLRZ B,(TT)
HRLM A,(TT)
HRLM B,(T)
POPJ P,
;pname builder
PNAMAK: MOVE T,IDPTR
PUSHJ P,NCONS
MOVE TT,A
MOVE C,A
PNAMB: MOVE A,(T)
TRZ A,1 ;clear low bit!!!!!
PUSHJ P,FWCONS
PUSHJ P,NCONS
HRRM A,(TT)
MOVE TT,A
AOBJN T,PNAMB
MOVE A,C
HRLZS (A)
JRST PNGNK1+1
;number builder
NUMAK: MOVEM A,OLDCH
HRRI R,NUMCLS ;number
MOVEI A,0
IDPB A,C
IDPB A,C
HRRZS C
CAML C,JRELO ;top of spec pdl
JRST SPDLOV
MOVSI C,(POINT 7,0,35)
HRRI C,(SP)
TLNE T,SAWDOT+EXP
JRST NUMAK2 ;decimal number or flt pt
FOO MOVE A,VIBASE ;ibase integrer
SUBI A,INUM0
PUSHJ P,NUM
NUMAK4:
FOO MOVEI B,FIXNUM
NUMAK6: TLNE T,MINSGN
MOVNS A
JRST MAKNUM
NUMAK2: PUSHJ P,NUM10
MOVEM A,TT
TLNN T,SAWDOT
JRST [ PUSHJ P,FLOAT ;flt pt without fraction
MOVE TT,A
JRST NUMAK3]
PUSHJ P,NUM10 ;fraction part
EXCH A,TT
TLNN T,EXP
JUMPE AR2A,NUMAK4 ;no exponent and no fraction
PUSHJ P,FLOAT
EXCH A,TT
PUSHJ P,FLOAT
MOVEI AR1,FT01
PUSHJ P,FLOSUB
FMPR A,B
FADRM A,TT
NUMAK3: PUSHJ P,NUM10 ;exponent part
MOVE AR2A,A
MOVEI AR1,FT-1
TLNE T,NEXP
MOVEI AR1,FT01 ;-exponent
PUSHJ P,FLOSUB
FMPR TT,B ;positive exponent
FOO MOVEI B,FLONUM
MOVE A,TT
JFCL 10,FLOOV
JRST NUMAK6
FLOSUB: MOVSI B,(1.0)
TRZE AR2A,1
FMPR B,(AR1)
JUMPE AR2A,CPOPJ
LSH AR2A,-1
SOJA AR1,FLOSUB+1
;variable radix integer builder
NUM10: MOVEI A,TEN
NUM: HRRM A,NUM1
JFCL 10,.+1 ;clear CARRY0 flag
SETZB A,AR2A
NUM2: ILDB B,C
JUMPE B,CPOPJ ;done
NUM1: IMULI A,X
ADDI A,-"0"(B)
NUM3: JFCL 10,FIXOV ;bignums change this to JFCL 10,RDBNM
AOJA AR2A,NUM2
INTERN: MOVEM A,AR2A
PUSHJ P,PNAMUK
PUSHJ P,IDSUB
MOVEI AR1,1
PUSHJ P,INTER1 ;is it in oblist
POPJ P, ;found it
MOVE A,AR2A ;not there
JRST MAKID2 ;put it there
REMOB: JUMPE A,FALSE
MOVEI AR1,1
PUSH P,A
HLRZ A,(A)
PUSHJ P,INTERN
HLRZ B,@(P)
CAME A,B
JRST REMOB2
HRRZ B,CURBUC
RHX5:
FOO HLRZ C,OBTBL+X(B)
HLRZ T,(C)
CAMN T,A
JRST [ HRRZ TT,(C)
HRLM TT,@RHX5
JRST REMOB2]
REMOB3: MOVE TT,C
HRRZ C,(C)
HLRZ T,(C)
CAME T,A
JRST REMOB3
HRRZ T,(C)
HRRM T,(TT)
REMOB2: POP P,A
HRRZ A,(A)
JRST REMOB
SUBTTL LISP INTERPRETER SUBROUTINES --- PAGE 10
CADDDR: SKIPA A,(A)
CADDAR: HLRZ A,(A)
CADDR: SKIPA A,(A)
CADAR: HLRZ A,(A)
CADR: SKIPA A,(A)
CAAR: HLRZ A,(A)
CAR: HLRZ A,(A)
POPJ P,
CDDDDR: SKIPA A,(A)
CDDDAR: HLRZ A,(A)
CDDDR: SKIPA A,(A)
CDDAR: HLRZ A,(A)
CDDR: SKIPA A,(A)
CDAR: HLRZ A,(A)
CDR: HRRZ A,(A)
POPJ P,
CAADDR: SKIPA A,(A)
CAADAR: HLRZ A,(A)
CAADR: SKIPA A,(A)
CAAAR: HLRZ A,(A)
JRST CAAR
CDADDR: SKIPA A,(A)
CDADAR: HLRZ A,(A)
CDADR: SKIPA A,(A)
CDAAR: HLRZ A,(A)
JRST CDAR
CAAADR: SKIPA A,(A)
CAAAAR: HLRZ A,(A)
JRST CAAAR
CDDADR: SKIPA A,(A)
CDDAAR: HLRZ A,(A)
JRST CDDAR
CDAADR: SKIPA A,(A)
CDAAAR: HLRZ A,(A)
JRST CDAAR
CADADR: SKIPA A,(A)
CADAAR: HLRZ A,(A)
JRST CADAR
QUOTE: HLRZ A,(A) ;car and quote duplicated for backtrace
POPJ P,
AASCII: PUSHJ P,NUMVAL
AASC1: LSH A,↑D29
PUSHJ P,FWCONS
PUSHJ P,NCONS
PNGNK1: PUSHJ P,NCONS
FOO MOVEI B,PNAME
PUSHJ P,XCONS
ACONS: TROA B,-1
NCONS: TRZA B,-1
XCONS: EXCH B,A
CONS: AOS CONSVAL
HRL B,A
SKIPN A,F
JRST [ HLR A,B
PUSHJ P,AGC
JRST .-1]
MOVE F,(F)
MOVEM B,(A)
POPJ P,
;new consing routines-not finished yet
;acons: troa b,-1
;ncons: trz b,-1
;cons: exch b,a
;xcons: hrl a,b
; exch a,(f)
; exch a,f
; popj p,
PATOM: CAIL A,@GCP1
JRST TRUE
CAIL A,@GCPP1
ATOM: CAILE A,INUMIN
JRST TRUE
HLLE A,(A)
AOJE A,TRUE
JRST FALSE
; (CHRVAL X) returns, as an INUM, the ASCII value of the first character
; of the PNAME of X
CHRVAL:
FOO MOVEI B,PNAME
PUSHJ P,GET
HLRZ A,(A)
MOVE A,(A)
LSH A,-35
JRST FIX1A
EQ: CAMN A,B
JRST TRUE
JRST FALSE
LENGTH: MOVEI B,0
LNGTH1: CAILE A,INUMIN
JRST FIX1
HLLE C,(A)
AOJE C,FIX1
HRRZ A,(A)
AOJA B,LNGTH1
LAST: HRRZ B,(A)
CAILE B,INUMIN
POPJ P,
HLLE B,(B)
AOJE B,CPOPJ
HRRZ A,(A)
JRST LAST
RPLACA: HRLM B,(A)
POPJ P,
RPLACD: HRRM B,(A)
POPJ P,
ZEROP: PUSHJ P,NUMVAL
NOT:
NULL: JUMPN A,FALSE
TRUE:
FOO MOVEI A,TRUTH
POPJ P,
FW0CNS: MOVEI A,0
FWCONS: JUMPN FF,FWC1
EXCH A,FWC0#
PUSHJ P,AGC
EXCH A,FWC0
FWC1: EXCH A,(FF)
EXCH A,FF
POPJ P,
SASSOC: PUSHJ P,SAS1
JCALLF 0,(C)
POPJ P,
SAS0: HLRZ B,T
SAS1: JUMPE B,CPOPJ
MOVS T,(B)
MOVS TT,(T)
CAIE A,(TT)
JRST SAS0
HRRZ A,T
CPOPJ1: AOS (P)
POPJ P,
ASSOC: PUSHJ P,SAS1
FALSE: MOVEI A,NIL
CPOPJ: POPJ P,
REVERSE: MOVE T,A
MOVEI A,0
JUMPE T,CPOPJ
HLRZ B,(T)
HRRZ T,(T)
PUSHJ P,XCONS
JUMPN T,.-3
POPJ P,
REMPROP: HRRZ T,(A)
MOVS TT,(T)
CAIN B,(TT)
JRA TT,REMP1
HLRZ A,TT
HRRZ T,(A)
JUMPN T,REMPROP+1
JRST FALSE
REMP1: HRRM TT,(A)
JRST TRUE
GET: HRRZ A,(A)
MOVS D,(A)
CAIN B,(D)
JRST CADR
HLRZ A,D
HRRZ A,(A)
JUMPN A,GET+1
POPJ P,
GETL: HRRZ A,(A)
GETL0: HLRZ T,(A)
MOVE C,B
GETL1: MOVS TT,(C)
CAIN T,(TT)
POPJ P,
HLRZ C,TT
JUMPN C,GETL1
HRRZ A,(A)
HRRZ A,(A)
JUMPN A,GETL0
POPJ P,
NUMBERP: CAILE A,INUMIN
JRST TRUE
HLLE T,(A)
AOJN T,FALSE
HRRZ A,(A)
HLRZ A,(A)
FOO CAIE A,FIXNUM
FOO CAIN A,FLONUM
JRST TRUE
NUMBP2: JRST FALSE ;bignums change this to JRST BIGNP
PUTPROP: MOVE T,A
HRRZ A,(A)
CSET3: MOVS TT,(A)
HLRZ A,TT
CAIN C,(TT)
JRST CSET2
HRRZ A,(A)
JUMPN A,CSET3
HRRZ A,(T)
PUSHJ P,XCONS
HRRZ B,C
PUSHJ P,XCONS
HRRM A,(T)
JRST CADR
CSET2:
FOO CAIE C,VALUE
JRST CSET1
HRRZ T,(B)
HLRZ A,(A)
HRRM T,(A)
JRST PROG2
CSET1: HRLM B,(A)
PROG2: MOVE A,B
POPJ P,
DEFPROP:
HRRZ B,(A)
HRRZ C,(B)
HLRZ A,(A)
HLRZ B,(B)
HLRZ C,(C)
PUSH P,A
PUSHJ P,PUTPROP
JRST POPAJ
EQUAL: MOVE C,P
EQUAL1: CAMN A,B
JRST TRUE
MOVE T,A
MOVE TT,B
PUSHJ P,ATOM
EXCH A,B
PUSHJ P,ATOM
CAMN A,B
JRST EQUAL3
EQUAL4: MOVE P,C
JRST FALSE
EQUAL3: JUMPN A,EQ2
PUSH P,T
PUSH P,TT
HLRZ A,(T)
HLRZ B,(TT)
PUSHJ P,EQUAL1
JUMPE A,EQUAL4
POP P,B
POP P,A
HRRZ A,(A)
HRRZ B,(B)
JRST EQUAL1
EQ2: PUSH P,T
MOVE A,T
PUSHJ P,NUMBERP
JUMPE A,EQUAL4
MOVE A,TT
PUSHJ P,NUMBERP
JUMPE A,EQUAL4
MOVE A,(P)
MOVEM C,(P)
MOVE B,TT
JSP C,OP
JUMPL COMP3
JUMPL COMP3
COMP3: POP P,C
CAME A,TT
JRST EQUAL4
JRST TRUE
SUBS5: HRRZ A,SUBAS
POPJ P,
SUBST: MOVEM A,SUBAS#
MOVEM B,SUBBS#
SUBS0A: MOVE A,SUBAS
MOVE B,SUBBS
PUSH P,C
MOVE A,C
PUSHJ P,EQUAL
POP P,C
JUMPN A,SUBS5
CAILE C,INUMIN
JRST EV6A
HLLE T,(C)
AOJN T,SUBS2
EV6A: MOVE A,C
POPJ P,
SUBS2: PUSH P,C
HLRZ C,(C)
PUSHJ P,SUBS0A
EXCH A,(P)
HRRZ C,(A)
PUSHJ P,SUBS0A
POP P,B
JRST XCONS
NCONC: TDZA R,R
APPEND: MOVEI R,.APPEND-.NCONC
JUMPE T,FALSE
POP P,B
APP2: AOJE T,PROG2
POP P,A
PUSHJ P,.NCONC(R)
MOVE B,A
JRST APP2
.NCONC: JUMPE A,PROG2
MOVE TT,A
MOVE C,TT
HRRZ TT,(C)
JUMPN TT,.-2
HRRM B,(C)
POPJ P,
.APPEND: JUMPE A,PROG2
MOVEI C,AR1
MOVE TT,A
APP1: HLRZ A,(TT)
PUSH P,B
PUSHJ P,CONS ;saves b
POP P,B
HRRM A,(C)
MOVE C,A
HRRZ TT,(TT)
JUMPN TT,APP1
JRST SUBS4
MEMBER: MOVEM A,SUBAS
MEMB1: JUMPE B,FALSE
MOVEM B,SUBBS
MOVE A,SUBAS
HLRZ B,(B)
PUSHJ P,EQUAL
JUMPN A,CPOPJ
MOVE B,SUBBS
HRRZ B,(B)
JRST MEMB1
MEMQ: JUMPE B,FALSE
MOVS C,(B)
CAIN A,(C)
JRST TRUE
HLRZ B,C
JUMPN B,MEMQ+1
JRST FALSE
AND:
FOO HRLI A,TRUTH
OR: HLRZ C,A
PUSH P,C
ANDOR: HRRZ C,A
JUMPE C,AOEND
MOVSI C,(SKIPE (P))
TLNE A,-1
MOVSI C,(SKIPN (P))
XCT C
JRST AOEND
MOVEM A,(P)
HLRZ A,(A)
PUSHJ P,EVAL
EXCH A,(P)
HRR A,(A)
JRST ANDOR
AOEND: POP P,A
SKIPE A
FOO MOVEI A,TRUTH
POPJ P,
GENSYM: MOVE B,[POINT 7,GNUM,34]
MOVNI C,4
MOVEI TT,"0"
GENSY2: LDB T,B
AOS T
DPB T,B
CAIG T,"9"
JRST GENSY1
DPB TT,B
ADD B,[XWD 70000,0]
AOJN C,GENSY2
GENSY1: MOVE A,GNUM
PUSHJ P,FWCONS
PUSHJ P,NCONS
JRST PNGNK1
GNUM: ASCII /G0000/ ;*
CSYM: HLRZ A,(A)
PUSH P,A
FOO MOVEI B,PNAME
PUSHJ P,GET
JUMPE A,NOPNAM
HLRZ A,(A)
MOVE A,(A)
MOVEM A,GNUM
JRST POPAJ
LIST: MOVE B,A
FOO MOVEI A,CEVAL
JRST MAPCAR
EELS: HLRZ TT,(T) ;interpret lsubr call
HRRZ A,(AR1)
ILIST: MOVEI T,0
JUMPE A,ILIST2
ILIST1: PUSH P,A
HLRZ A,(A)
PUSH P,TT
HRLM T,(P)
PUSHJ P,EVAL
ILIST3: POP P,TT
HLRE T,TT
EXCH A,(P)
HRRZ A,(A)
SOS T
JUMPN A,ILIST1
ILIST2: JRST (TT)
MAPC: TLO A,400000
MAP: TLOA A,200000
MAPCAR: TLO A,400000
MAPLIST: JUMPE B,FALSE
PUSH P,A
PUSH P,B
PUSH P,B
HRLZM P,(P)
MAPL2: MOVE A,-1(P)
SKIPGE -2(P)
HLRZ A,(A)
CALLF 1,@-2(P)
LDB C,[POINT 1,-2(P),1]
JUMPN C,MAP1
PUSHJ P,NCONS
HLR B,(P)
HRRM A,(B)
HRLM A,(P)
MAP1: HRRZ B,@-1(P)
MOVEM B,-1(P)
JUMPN B,MAPL2
POP P,AR1
SUB P,[XWD 2,2]
SUBS4: HRRZ A,AR1
POPJ P,0
PA3: 0 ;lh=0=>rh =next prog statement *
;lh - =>rh = tag to go to
PA4: 0 ;lh=-1,rh=pntr to prog less bound var list *
;lh=+,rh return value
;2.1=>dont do unbnd
PROG: PUSH P,PA3
PUSH P,PA4
HLRZ TT,(A)
HRRZ A,(A)
HRROM A,PA4
MOVEM A,PA3
JUMPE TT,PG0
MOVSI C,1
FOO MOVEI B,VALUE
MOVEM SP,SPSV#
ANDCAM C,PA4
PG7A: HLRZ A,(TT)
MOVEI AR1,0
PUSHJ P,BIND
HRRZ TT,(TT)
JUMPN TT,PG7A
PUSH SP,SPSV
PG0: SKIPA T,PA3
PG5A: MOVE T,A
PG1: JUMPE T,PG2
HLRZ A,(T)
HRRZ T,(T)
HLLE B,(A)
AOJE B,PG1
MOVEM T,PA3
PUSHJ P,EVAL
SKIPL A,PA4
JRST PG4 ;return
SKIPL T,PA3
JRST PG1
PG5: JUMPE A,EG1
HLRZ TT,(A)
HRRZ A,(A)
CAIN TT,(T)
JRST PG5A ;found tag
JRST PG5
PG2: TDZA A,A
PG4: HRRZS A
MOVSI B,1
TDNN B,PA4
PUSHJ P,UNBIND
ERRP4: POP P,PA4
POP P,PA3
POPJ P,
GO: HLRZ A,(A)
HRROM A,PA3
HLLE B,(A)
AOJE B,FALSE
PUSHJ P,EVAL
JRST GO+1
RETURN: HLL A,PA4
TLZ A,-2
MOVEM A,PA4
POPJ P,
SETQ: HLRZ B,(A)
PUSH P,B
PUSHJ P,CADR
PUSHJ P,EVAL
MOVE B,A
POP P,A
SET: MOVE AR1,B
PUSHJ P,BIND
SUB SP,[XWD 1,1]
IFN ML2,<
SKIPE ML2ROUT ;ON IF MLISP2 ACTIVE
SUB SP,[XWD 1,1] ;TWO WORDS STORED PER SPECIAL
>;ML2
MOVE A,AR1
POPJ P,
CON2: HRRZ A,(T)
COND: JUMPE A,CPOPJ ;entry
PUSH P,A
HLRZ A,(A)
HLRZ A,(A)
PUSHJ P,EVAL
POP P,T
JUMPE A,CON2
HLRZ T,(T)
COND2: HRRZ T,(T)
JUMPE T,CPOPJ
PUSH P,T
HLRZ A,(T)
PUSHJ P,EVAL
POP P,T
JRST COND2
SUBTTL ARITHMETIC SUBROUTINES --- PAGE 11
;macro expander -- (foo a b c) => (*foo (*foo a b) c)
EXPAND: MOVE C,B
HRRZ A,(A)
PUSHJ P,REVERSE
JRST EXPA1
EXPN1: MOVE C,B
EXPA1: HRRZ T,(A)
HLRZ A,(A)
JUMPE T,CPOPJ
PUSH P,A
MOVE A,T
PUSHJ P,EXPA1
EXCH A,(P)
PUSHJ P,NCONS
POP P,B
PUSHJ P,XCONS
MOVE B,C
JRST XCONS
ADD1: CAILE A,INUMIN
CAIL A,-2
SKIPA B,[INUM0+1]
AOJA A,CPOPJ
.PLUS: JSP C,OP
ADD A,TT
FADR A,TT
SUB1: CAILE A,INUMIN+1
SOJA A,CPOPJ
MOVEI B,INUM0+1
.DIF: JSP C,OP
SUB A,TT
FSBR A,TT
.TIMES: JSP C,OP
IMUL A,TT
FMPR A,TT
.QUO: CAIN B,INUM0
JRST ZERODIV
JSP C,OP
IDIV A,TT
FDVR A,TT
.GREAT: EXCH A,B
JUMPE B,FALSE
.LESS: JUMPE A,CPOPJ
JSP C,OP
JRST COMP2 ;bignums know about me
JRST COMP2
COMP2: CAML A,TT
JRST FALSE
JRST TRUE
MAKNUM:
FOO CAIN B,FIXNUM
JRST FIX1A
FLO1A:
FOO MOVEI B,FLONUM
PUSHJ P,FWCONS
JRST ACONS-1
FIX1B: SUBI A,INUM0
FOO MOVEI B,FIXNUM
PUSHJ P,FWCONS
JRST ACONS-1
NUMVLX: JFCL 17,.+1
NUMVAL: CAIG A,INUMIN
JRST NUMAG1
SUBI A,INUM0
FOO MOVEI B,FIXNUM
POPJ P,
NUMAG1: MOVEM A,AR1
HRRZ A,(A)
HLRZ B,(A)
HRRZ A,(A)
FOO CAIE B,FIXNUM
FOO CAIN B,FLONUM
SKIPA A,(A)
NUMV4: SKIPA A,AR1
POPJ P,
NUMV2: PUSHJ P,EPRINT ;bignums know about me
JRST NONNUM
NUMV3: JRST NONNUM ;bignums change me to JRST BIGDIS
FLOAT: IDIVI A,400000
SKIPE A
TLC A,254000
TLC B,233000
FADR A,B
POPJ P,
FIX: PUSH P,A
PUSHJ P,NUMVAL
FOO CAIE B,FLONUM
JRST POPAJ
MULI A,400
TSC A,A
JFCL 17,.+1
ASH B,-243(A)
FIX2: JFCL 10,FIXOV ;bignums change me to jfcl 10,bfix
POP P,A
FIX1: MOVE A,B
JRST FIX1A
MINUSP: PUSHJ P,NUMVAL
JUMPGE A,FALSE
JRST TRUE
MINUS: PUSHJ P,NUMVLX
MOVNS A
JFCL 10,@OPOV
JRST MAKNUM
ABS: PUSHJ P,NUMVLX
MOVMS A
JRST MINUS+2
DIVIDE: CAIN B,INUM0
JRST ZERODIV
JSP C,OP
JUMPN RDIV ;bignums know about me
JRST ILLNUM
RDIV: IDIV A,TT
PUSH P,B
PUSHJ P,FIX1A
EXCH A,(P)
PUSHJ P,FIX1A
POP P,B
JRST XCONS
REMAINDER:
PUSHJ P,DIVIDE
JRST CDR
FIXOV: ERR1 [SIXBIT /INTEGER OVERFLOW!/]
ZERODIV:ERR1 [SIXBIT /ZERO DIVISOR!/]
FLOOV: ERR1 [SIXBIT /FLOATING OVERFLOW!/]
ILLNUM: ERR1 [SIXBIT /NON-INTEGRAL OPERAND!/]
GCD: JSP C,OP
JUMPA GCD2 ;bignums know about me
JRST ILLNUM
GCD2: MOVMS A
MOVMS TT
;euclid's algorithm
GCD3: CAMG A,TT
EXCH A,TT
JUMPE TT,FIX1A
IDIV A,TT
MOVE A,B
JRST GCD3
;general arithmetic op code routine for mixed types
OP: CAIG A,INUMIN
JRST OPA1
SUBI A,INUM0
CAIG B,INUMIN
JRST OPA2
HRREI TT,-INUM0(B)
XCT (C) ;inum op (cannot cause overflow)
FIX1A: ADDI A,INUM0
CAILE A,INUMIN
CAIL A,-1
JRST FIX1B
POPJ P,
OPA1: HRRZ A,(A)
HLRZ T,(A)
HRRZ A,(A)
FOO CAIE T,FIXNUM
JRST OPA6
SKIPA A,(A)
OPA2:
FOO MOVEI T,FIXNUM
CAILE B,INUMIN
JRST OPB2
HRRZ B,(B)
HRRZ TT,(B)
HLRZ B,(B)
FOO CAIE B,FIXNUM
JRST OPA5
SKIPA TT,(TT)
OPB2: HRREI TT,-INUM0(B)
MOVE AR1,A
JFCL 17,.+1
XCT (C) ;fixed pt op
OPOV: JFCL 10,FIXOV ;bignums change this to jfcl 10,fixovl
JRST FIX1A
OPA6: CAILE B,INUMIN
JRST OPB7
HRRZ B,(B)
HRRZ TT,(B)
HLRZ B,(B)
FOO CAIE B,FLONUM
JRST OPB3
FOO CAIE T,FLONUM
JRST NUMV3
MOVE A,(A)
MOVE TT,(TT)
OPR: JFCL 17,.+1
XCT 1(C) ;flt pt op
JFCL 10,FLOOV
JRST FLO1A
OPA5:
FOO CAIE B,FLONUM
JRST NUMV3
PUSHJ P,FLOAT
JRST OPR-1
OPB3:
FOO CAIE B,FIXNUM
JRST NUMV3
SKIPA TT,(TT)
OPB7: HRREI TT,-INUM0(B)
FOO MOVEI B,FIXNUM
FOO CAIE T,FLONUM
JRST NUMV3
MOVE A,(A)
EXCH A,TT
PUSHJ P,FLOAT
EXCH A,TT
JRST OPR
SUBTTL EXPLODE, READLIST AND FRIENDS --- PAGE 12
FLATSIZE: HLLZS FLAT1
MOVEI R,FLAT2
PUSHJ P,PRINTA
FLAT1: MOVEI A,X ;*
JRST FIX1A
FLAT2: AOS FLAT1
POPJ P,
%EXPLODE: SKIPA R,.+1
EXPLODE: HRRZI R,EXPL1
MOVSI AR1,AR1
PUSHJ P,PRINTA
JRST SUBS4
EXPL1: PUSH P,B
PUSH P,C
ANDI A,177
CAIL A,"0"
CAILE A,"9"
JRST EXPL2
ADDI A,INUM0-"0"
JRST EXPL4
EXPL2: PUSH P,AR1
PUSH P,TT
PUSH P,T
LSH A,35
MOVE C,SP
PUSH C,A
MOVEI AR1,1
PUSHJ P,INTER0
POP P,T
POP P,TT
POP P,AR1
EXPL4: PUSHJ P,NCONS
HLR B,AR1
HRRM A,(B)
HRLM A,AR1
POP P,C
JRST POPBJ
READLIST: TDZA T,T
MAKNAM: MOVNI T,1
MOVEM T,NOINFG
PUSH P,OLDCH
SETZM OLDCH
JUMPE A,NOLIST
HRRM A,MKNAM3
MOVEI A,MKNAM2
PUSHJ P,READ0
HRRZ T,MKNAM3
CAIE T,-1
JUMPN T,[ERR1 [SIXBIT /MORE THAN ONE S-EXPRESSION-MKNAM!/]]
POP P,OLDCH
POPJ P,
MKNAM2: PUSH P,B
PUSH P,T
PUSH P,TT
MKNAM3: MOVEI TT,X
JUMPE TT,MKNAM6
CAIN TT,-1
ERR1 [SIXBIT /READ UNHAPPY-MAKNAM!/]
HRRZ B,(TT)
HRRM B,MKNAM3
HLRZ A,(TT)
CAIGE A,INUMIN
JRST MKNAM5
SUBI A,INUM0-"0"
MKNAM4: POP P,TT
POP P,T
JRST POPBJ
MKNAM5: HLRZ A,(TT)
FOO MOVEI B,PNAME
PUSHJ P,GET
HLRZ A,(A)
LDB A,[POINT 7,(A),6]
JRST MKNAM4
MKNAM6: MOVEI A," "
HLLOS MKNAM3
JRST MKNAM4
SUBTTL EVAL APPLY -- THE INTERPRETER --- PAGE 13
EV3: HLRZ A,(AR1)
FOO MOVEI B,VALUE
PUSHJ P,GET
JUMPE A,UNDFUN ;function object has no definition
HRRZ A,(A)
UBDPTR:
FOO CAIN A,UNBOUND
JRST UNDFUN
HRRZ B,(AR1) ;eval (cons (cdr a)(cdr ar1))
PUSHJ P,CONS
JRST EVAL
OEVAL: AOJN T,AEVAL
POP P,A
EVAL: HRRZM A,AR1
CAILE A,INUMIN
JRST CPOPJ
HLRZ T,(A)
CAIN T,-1
JRST EE1 ;x is atomic
CAILE T,INUMIN
JRST UNDFUN
HLRO TT,(T)
AOJE TT,EE2 ;car (x) is atomic
JRST EXP3
EE1:
EV5: HRRZ AR1,(AR1)
JUMPE AR1,UNBVAR
HLRZ TT,(AR1)
FOO CAIE TT,FLONUM
FOO CAIN TT,FIXNUM
POPJ P,
EVBIG: HRRZ AR1,(AR1) ;bignums know about me
FOO CAIE TT,VALUE
JRST EV5
HLRZ AR1,(AR1)
HRRZ AR1,(AR1)
FOO CAIN AR1,UNBOUND
JRST UNBVAR
MOVEM AR1,A
POPJ P,
ALIST: SKIPE A,-1(P)
PUSHJ P,NUMBERP
MOVEM SP,SPSV
JUMPN A,AEVAL7 ;number
MOVE C,SC2 ;bottom of spec pdl
MOVEM C,AEVAL5#
SETOM AEVAL2
AEVAL8: MOVE C,SP
AEVAL6: CAMN C,AEVAL5 ;bottom spec pdl
JRST AEVAL1 ;done
POP C,T ;pointer for next block
AEVAL4: CAMN C,T
JRST AEVAL6 ;thru with block
POP C,AR1
MOVSS AR1
PUSH SP,(AR1) ;save value cell
HLRZM AR1,(AR1) ;store previous value in value cell
HRLM AR1,(SP) ;save pointer to spec pdl loc
JRST AEVAL4
FNGUBD: EXCH A,(P) ;spec pdl pointer
PUSHJ P,NUMVAL
MOVE D,A
POP SP,TT ;end of block to rebind
FNGUB2: CAMN SP,TT
JRST POPAJ ;done
POP SP,T
MOVSS T ;pointer to value cell
HRLM T,(T)
SKIPGE 1(D)
AOBJN D,.-1 ;skip over spec pdl pointers
PUSH D,(T) ;put value cell in spec pdl
HLRZM T,(T) ;restore value cell
JRST FNGUB2
AEVAL: PUSHJ P,ALIST
POP P,A
MOVEI A,UNBIND
EXCH A,(P)
JRST EVAL
AEVAL1: SKIPGE AEVAL2
SKIPN B,-1(P)
JRST ABIND3 ;done with binding
;alist binding
MOVE A,B
PUSHJ P,REVERSE
SKIPA
ABIND2: MOVE A,B
HRRZ B,(A)
HLRZ A,(A)
HRRZ AR1,(A)
HLRZ A,(A)
PUSHJ P,BIND
JUMPN B,ABIND2
ABIND3: PUSH SP,SPSV
POPJ P,
;spec pdl binding
AEVAL7: MOVE A,-1(P)
PUSHJ P,NUMVAL
CLEARM AEVAL2
MOVEM A,AEVAL5 ;point to unbind to
JRST AEVAL8
AEVAL2: 0 ;0 for number, -1 for a-list *
EE2: HRRZ T,(T)
JUMPE T,EV3
HLRZ TT,(T)
HRRZ T,(T)
FOO CAIN TT,SUBR
JRST ESB
FOO CAIN TT,LSUBR
JRST EELS
FOO CAIN TT,EXPR
JRST AEXP
FOO CAIN TT,FSUBR
JRST EFS
FOO CAIN TT,MACRO
JRST EFM
FOO CAIE TT,FEXPR
JRST EE2
HLRZ T,(T)
HLL T,(AR1)
PUSH P,T
HRRZ A,(A)
TLO A,400000
PUSH P,A
MOVNI T,1
JRST IAPPLY
AEXP: HLRZ T,(T)
HLL T,(AR1)
EXP3: PUSH P,T
HRRZ A,(AR1)
CILIST: JSP TT,ILIST
EXP2: JRST IAPPLY
EFS: HLRZ T,(T)
HRRZ A,(AR1)
JRST (T)
ESB: HRRZ A,(AR1)
UUOS2: HLRZ T,(T)
HLL T,(AR1)
PUSH P,T
JSP TT,ILIST
ESB1: JRST .+NACS+1(T)
POP P,A+4
POP P,A+3
POP P,A+2
POP P,A+1
POPAJ: POP P,A
POPJ P,
EFM: HLRZ T,(T)
CALLF 1,(T)
JRST EVAL
APPLY: MOVEI TT,AP2
CAME T,[-3]
JRST PDLARG
MOVEM T,APFNG1#
PUSHJ P,ALIST
MOVE T,APFNG1
JSP TT,PDLARG
PUSH P,C ;spec pdl pointer
PUSH P,[FNGUBD]
AP2: PUSH P,A
MOVEI T,0
AP3: JUMPE B,IAPPLY ;all args pushed; b has arg list
HLRZ C,(B)
PUSH P,C ;push arg
HRRZ B,(B)
SOJA T,AP3
IAP4: JUMPGE D,TOOFEW ;special case for fexprs
AOJN R,TOOFEW
PUSH P,B
MOVE A,SP
PUSHJ P,FIX1A
EXCH A,(P)
MOVE B,A
MOVNI R,2
SOJA T,IAP5
FUNCT: PUSH P,A
MOVE A,SP
PUSHJ P,FIX1A
POP P,B
HLRZ B,(B)
PUSHJ P,XCONS
FOO MOVEI B,FUNARG
JRST XCONS
APFNG: SOS T
MOVEM T,APFNG1
JSP TT,PDLARG ;get args and funarg list
HRRZ A,(A)
HRRZ D,(A) ;a-list pointer
HLRZ A,(A) ;function
HRLZ R,APFNG1 ;no. of args
PUSH P,D
PUSH P,[FNGUBD]
JSP TT,ARGP1 ;replace args and fn name
PUSH P,D ;a-list pointer
PUSHJ P,ALIST ;set up spec pdl
POP P,D
AOS T,APFNG1
;falls through
;falls in
IAPPLY: MOVE C,T ;state of world at entrance
ADDI C,(P) ;t has - number of args on pdl
ILP1A: HRRZ B,(C) ;next pdl slot has function- poss fun name in lh
CAILE B,INUMIN
JRST UNDTAG
HLRZ A,(B)
CAIN A,-1
JRST IAP1 ;fn is atomic
FOO CAIN A,LAMBDA
JRST IAPLMB
FOO CAIN A,FUNARG
JRST APFNG
FOO CAIN A,LABEL
JRST APLBL
PUSH P,T
MOVE A,B
PUSHJ P,EVAL
POP P,T
MOVE C,T
ADDI C,(P)
ILP1B: MOVEM A,(C)
JRST ILP1A
IAPXPR: HLRZ A,(B)
JRST ILP1B
IAP1: HRRZ B,(B)
JUMPE B,IAP2
HLRZ TT,(B)
HRRZ B,(B)
FOO CAIN TT,EXPR
JRST IAPXPR
FOO CAIN TT,LSUBR
JRST IAP6
FOO CAIE TT,SUBR
JRST IAP1
HLRZ B,(B)
MOVEM B,(C)
JRST ESB1
IAPLMB: HRRZ B,(B)
HLRZ TT,(B)
MOVEM SP,SPSV
HRRZ B,(B)
HLRZ D,(TT)
CAIN D,-1
JUMPN TT, IAP3
MOVE R,T
IPLMB1: JUMPE T,IPLMB2 ;no more args
JUMPE TT,TOMANY ;too many args supplied
IAP5: HLRZ A,(TT)
MOVEI AR1,1(T)
ADD AR1,P
HLLZ D,(AR1)
HRLM A,(AR1)
HRRZ TT,(TT)
AOJA T,IPLMB1
IPLMB2: JUMPN TT,IAP4 ;too few args supplied
JUMPE R,IAP69
IPLMB4: POP P,AR1
HLRZ A,AR1
AOJG R,IPLMB3
PUSHJ P,BIND
JRST IPLMB4
IPLMB3: SKIPE BACTRF
JRST APBK1
APBK2: HLRZ A,(B)
PUSH SP,SPSV
PUSHJ P,EVAL
JRST UNBIND
IAP69: POP P,(P)
HLRZ A,(B)
JRST EVAL
APBK1: HRRI AR1,CPOPJ
TLNE AR1,-1
PUSH P,AR1
JRST APBK2
IAP6: MOVEI TT,CPOPJ
MOVEM TT,(C)
HLRZ B,(B)
JRST (B)
APLBL: MOVEM SP,SPSV
HRRZ B,(B)
HLRZ A,(B)
HRRZ B,(B)
HLRZ AR1,(B)
MOVEM AR1,(C)
PUSHJ P,BIND
MOVEI A,APLBL1
EXCH A,-1(C)
EXCH A,LBLAD#
HRLI A,LBLAD
IFN ML2,<
SKIPE ML2ROUT
PUSH SP,[NIL]
>;ML2
PUSH SP,A
PUSH SP,SPSV
JRST IAPPLY
APLBL1: PUSH P,LBLAD
JRST SPECSTR
IAP2: HRRZ A,(C)
FOO MOVEI B,VALUE
PUSHJ P,GET
JUMPE A,UNDTAG
HRRZ A,(A)
FOO CAIN A,UNBOUND
JRST UNDTAG
JRST ILP1B
IAP3: MOVNI AR1,-INUM0(T) ;lexpr call
MOVE A,TT
PUSHJ P,BIND
PUSH P,ARG
SUBI C,INUM0
HRRM C,ARG
PUSH SP,SPSV
HLRZ A,(B)
PUSHJ P,EVAL
HRRZ T,ARG
POP P,ARG
SUBI T,1-INUM0(P)
HRLI T,-1(T)
ADD P,T
JRST UNBIND
ARG: HRRZ A,X(A) ;*
POPJ P,
SETARG: HRRZM B,@ARG
JRST PROG2
BIND: PUSH P,B
HRRZM A,BIND3#
BIND2:
FOO MOVEI B,VALUE ;bind atom in a to value in ar1,save
PUSHJ P,GET ;old binding on s pdl
JUMPE A,BIND1 ;add value cell
IFN ML2,<
SKIPN ML2ROUT ;MLISP2 ACTIVE?
JRST [PUSH SP,(A)
JRST BIND22] ;NO
PUSH SP,BIND3;YES, NEED TO SAVE CONTEXT
>;ML2
PUSH SP,(A)
IFN ML2,<
PUSH P,A
MOVE A,BIND3
FOO MOVEI B,VALUE
PUSHJ P,@SAVE.CONTEXT
POP P,A
BIND22:
>;ML2
HRLM A,(SP)
HRRZM AR1,(A)
POPBJ: POP P,B
POPJ P,
BIND1:
FOO MOVEI B,UNBOUND
MOVEI A,0
PUSHJ P,CONS
HRRZ B,@BIND3
PUSHJ P,CONS
FOO MOVEI B,VALUE
PUSHJ P,XCONS
HRRM A,@BIND3
MOVE A,BIND3
JRST BIND2
UBD: CAMN SP,B
POPJ P,
PUSHJ P,UNBIND
JRST UBD
UNBIND:
SPECSTR: MOVE TT,(SP)
SUB SP,[XWD 1,1]
JUMPGE TT,.-2 ;syncronize stack
UNBND1: CAMN SP,TT
POPJ P,
POP SP,T
IFN ML2,<
SKIPN ML2ROUT
JRST UNBND8
PUSH P,A
PUSH P,B
POP SP,A
FOO MOVEI 2,VALUE
CAIE 1,NIL
PUSHJ P,@SAVE.CONTEXT
POP P,B
POP P,A
UNBND8:
>;ML2
MOVSS T
HLRZM T,(T)
JRST UNBND1
SPECBIND: MOVE TT,SP
SPEC1: LDB R,[POINT 13,(T),ACFLD]
CAILE R,17
JRST SPECX
SKIPE R
MOVE R,(R)
IFN ML2,<
SKIPN ML2ROUT
JRST SPECQ
PUSH P,A
PUSH P,AR1
MOVE A,(T)
MOVE AR1,R
PUSHJ P,BIND
POP P,AR1
POP P,A
JRST SPECZ
SPECQ:
>;ML2
EXCH R,@(T)
HRL R,(T)
PUSH SP,R
SPECZ: AOJA T,SPEC1
SPECX: PUSH SP,TT
JRST (T)
ML2SET: MOVEM A,ML2ROUT
MOVEI A,PA3
POPJ P,
SAVE.CONTEXT:
ML2ROUT:0 ;routine address for save.context when mlisp2
;random special case compiler run time routines
%AMAKE: PUSH P,A ;make alist for fsubr that requires it
MOVE A,SP
PUSHJ P,FIX1A
MOVE B,A
JRST POPAJ
%UDT: PUSHJ P,PRINT ;error print for undefined computed go tag
STRTIP [SIXBIT /UNDEFINED COMPUTED GO TAG IN !/]
HRRZ R,(P)
PUSHJ P,ERSUB3
JRST ERREND
%LCALL: MOVN A,T ;set up routine for compile lsubr
ADDI A,INUM0
ADDI T,(P)
PUSH P,T
PUSHJ P,(3)
POP P,T
SUBI T,(P)
HRLI T,-1(T)
ADD P,T
POPJ P,
SUBTTL ARRAY SUBROUTINES --- PAGE 14
ARRERR=-1
ARRAY: PUSHJ P,ARRAYS
HRRI AR2A,1(R)
MOVE A,AR2A
PUSH R,[0]
AOBJN A,.-1
ARREND: MOVE A,BPPNR#
MOVEM AR2A,-1(A)
MOVEI A,INUM0+1(R)
FOO MOVEM A,VBPORG
POPJ P,
ARRAYS: PUSH P,A
FOO MOVE A,VBPORG
SUBI A,INUM0
MOVEM A,BPPNR
FOO MOVE A,VBPEND
MOVNI A,-INUM0-2(A)
ADD A,BPPNR ;bporg-bpend+2
HRLM A,BPPNR
POP P,A
HRRZ AR1,(A) ;(cdr l)
HLRZ A,(A) ;(car l)name
HRRZ B,BPPNR
ADDI B,2
FOO MOVEI C,SUBR
PUSHJ P,PUTPROP
HLRZ A,(AR1) ;(cadr l)mode
PUSH P,AR1
PUSHJ P,EVAL ;eval mode
POP P,AR1
MOVEM A,AMODE#
MOVEI C,44
JUMPE A,ARRY1
MOVEI C,-INUM0(A)
CAILE A,INUMIN
JRST ARRY1
MOVEI C,22
HRRZ A,BPPNR
MOVE B,GCMKL
PUSHJ P,CONS
MOVEM A,GCMKL
ARRY1: MOVEM C,BSIZE#
MOVEI A,44
IDIV A,C
MOVEM A,NBYTES#
HRRZ A,(AR1) ;(cddr l)bound pair list
JSP TT,ILIST
AOS R,BPPNR
MOVEI AR1,1 ;ar1 is array size
MOVEI AR2A,0 ;ar2a is cumulative residue
AOJGE T,ARRYS ;single dimension
MOVEI D,A-1
SUB D,T ;d is next ac for array code generation
ARRY2: PUSHJ P,ARRB0
TLC TT,(IMULI)
DPB D,[POINT 4,TT,ACFLD]
PUSH R,TT
CAIN D,A
JRST ARRY3
MOVSI TT,(ADD)
ADDI TT,1(D)
DPB D,[POINT 4,TT,ACFLD]
PUSH R,TT
SOJA D,ARRY2
ARRB0: POP P,TT
EXCH TT,(P)
CAILE TT,INUMIN
JRST ARRB1
HLRZ A,(TT)
HRRZ TT,(TT)
SUBI TT,(A)
ADDI TT,1
JRST ARRB2
ARRB1: MOVEI A,INUM0
SUB TT,A
ARRB2: IMUL A,AR1
IMULB AR1,TT
ADDM A,AR2A
POPJ P,
ARRY3: PUSH R,[ADD A,B]
ARRYS: PUSHJ P,ARRB0
HRRZ TT,BPPNR
MOVEM AR2A,(TT)
HRLI TT,(SUB A,)
PUSH R,TT
PUSH R,[JUMPL A,ARRERR]
MOVE TT,AR1
HRLI TT,(CAIL A,)
PUSH R,TT
PUSH R,[JRST ARRERR]
IDIV AR1,NBYTES ;calc #words in array
SKIPE AR2A ;correct for remainder non-zero
ADDI AR1,1
MOVE TT,NBYTES
SOJE TT,ARRY6
ADDI TT,1
HRLI TT,(IDIVI A,)
PUSH R,TT
MOVN TT,BSIZE
LSH TT,14
HRLI TT,(IMULI B,)
PUSH R,TT
MOVEI TT,44+200
SUB TT,BSIZE
LSH TT,6
ARRY6: ADD TT,BSIZE
LSH TT,6
SKIPE AR2A,AMODE
CAIL AR2A,INUMIN
ADDI TT,40 ;mode not = t
TLC TT,(HRLZI C,)
PUSH R,TT
MOVEI TT,4(R)
HRLI TT,(ADDI C,(A))
PUSH R,TT
PUSH R,[LDB A,C]
HRLZI AR2A,(POPJ P,)
SKIPN TT,AMODE
MOVE AR2A,[JRST FLO1A]
CAIL TT,INUMIN
MOVE AR2A,[JRST FIX1A]
PUSH R,AR2A
MOVS AR2A,AR1
MOVNS AR2A
POPJ P,
EXARRAY: PUSH P,A
HLRZ A,(A)
PUSHJ P,GETSYM
JUMPE A,POPAJ
PUSHJ P,NUMVAL
EXCH A,(P)
PUSHJ P,ARRAYS
POP P,A
HRRM A,-2(R)
HRR AR2A,A
JRST ARREND
STORE: PUSH P,A
PUSHJ P,CADR
PUSHJ P,EVAL ;value to store
EXCH A,(P)
HLRZ A,(A)
PUSHJ P,EVAL ;byte pointer returned in c
POP P,A
NSTR: PUSH P,A
TLNE C,40
PUSHJ P,NUMVAL ;numerical array
DPB A,C
POP P,A
POPJ P,
SUBTTL EXAMINE, DEPOSIT , ETC --- PAGE 15
BOOLE: MOVE TT,T
ADDI TT,2(P)
MOVE A,-1(TT)
SUBI A,INUM0
DPB A,[POINT 4,BOOLI,OPFLD-2]
PUSHJ P,BOOLG
MOVE C,A
BOOLL: PUSHJ P,BOOLG
BOOLI: CLEARB C,A
JRST BOOLL
BOOLG: CAIL TT,(P)
JRST BOOL1
MOVE A,(TT)
PUSHJ P,NUMVAL
AOJA TT,CPOPJ
BOOL1: HRLI T,-1(T)
ADD P,T
POP P,B
JRST FIX1A
EXAMINE: MOVE A,-INUM0(A)
JRST FIX1A
DEPOSIT: MOVEI C,-INUM0(A)
MOVE A,B
PUSHJ P,NUMVAL
MOVEM A,(C)
JRST MAKNUM
LSH: MOVEI C,-INUM0(B)
PUSHJ P,NUMVAL
LSH A,(C)
JRST FIX1A
SUBTTL GARBAGE COLLECTER --- PAGE 16
;garbage collector
GC: PUSHJ P,AGC
JRST FALSE
AGC: MOVEM R,RGC#
IFN ML2,<
MOVEM SSTACK,SSTKSV#
MOVEM TSTACK,TSTKSV#
SETZB SSTACK,TSTACK
>;ML2
GCPK1: PUSH P,PA3
PUSH P,PA4
PUSH P,UBDPTR ;special atom UNBOUND; not on OBLIST
PUSH P,MKNAM3
PUSH P,GCMKL ;i/o channel input lists and arrays
PUSH P,BIND3
PUSH P,INITF
GCPK2: PUSH P,[XWD 0,GCP6] ;this is a return address
GCP4: MOVEI S,X ;pdlac, .=bottom of reg pdl + 1
GCP41: BLT S,X ;save ACs 0 through 10 at bottom of regpdl ;pdlac+n
GCP2: CLEARB 0,X ;gc indicator, init. for bit table zero
MOVE A,C3GC
GCP5: BLT A,X ;zero bit tables, .=top of bit tables
SKIPN GCGAGV
JRST GCP5A
SKIPN F
STRTIP [SIXBIT /←FREE STG EXHAUSTED←!/]
SKIPN FF
STRTIP [SIXBIT /←FULL WORD SPACE EXHAUSTED←!/]
GCP5A: MOVEI TT,1
MOVEI A,0
CALLI A,STIME ;time
MOVNS A
ADDM A,GCTIM#
GCP3: MOVEI C,X ;.=bottom of reg pdl
GCP6B: MOVE S,P
HLL C,P
MOVEI B,0
GC1: CAMN C,S
POPJ P,
HRRZ A,(C)
GCP: CAIGE A,X ;.=bottom of bit tables
GCPP1:
FOO CAIGE A,FS
JRST GCEND
GCP1: CAIL A,X ;.=bottom of full word space (fws)
JRST GCMFWS
MOVE F,(A)
LSHC A,-5
ROT B,5
MOVE AR1,GCBT(B)
GCBTP2: TDOE AR1,X(A) ;bit tab- (fs←-5), .=magic number for sync
JRST GCEND
GCBTP1: MOVEM AR1,X(A) ;bit tab- (fs←-5)
PUSH P,F
HLRZ A,F
JRST GCP
GCMFWS: MOVEI AR1,X(A) ;.=- bottom of fws
IDIVI AR1,44
MOVNS AR2A
LSH AR2A,36
ADD AR2A,C2GC
DPB TT,AR2A
GCEND: CAMN P,S
AOJA C,GC1
POP P,A
HRRZS A
JRST GCP
GCMKL: XWD 0,[XWD [XWD -NIOCH,CHTAB+FSTCH],0]
C2GC: XWD 430100+AR1,X ;.=bottom of fws bit table
C3GC: 0 ;(bottom bit table)bottom bit table+1
GCBT: XWD 400000,0
ZZ==1B1
XLIST
REPEAT ↑D31,<ZZ
ZZ==ZZ/2>
LIST
GCP6: HRRZ R,SC2
GCP6C: CAIL R,(SP) ;mark sp
JRST GCP6A
PUSH P,(R)
HRRZ C,P
PUSHJ P,GCP6B
SUB P,[XWD 1,1]
AOJA R,GCP6C
GCP6A: HRRZ R,GCMKL ;mark arrays
GCP6D: JUMPE R,GCSWP
HLRZ A,(R)
MOVE D,(A)
GCP6E: PUSH P,(D)
HRRZ C,P
PUSH P,(D)
MOVSS (P)
PUSHJ P,GCP6B
SUB P,[XWD 2,2]
AOBJN D,GCP6E
HRRZ R,(R)
JRST GCP6D
GFSWPP:
PHASE 0
GFSP1==.
JUMPL S,.+3
HRRZM F,(R)
HRRZ F,R
ROT S,1
AOBJN R,.-4
MOVE S,(D)
HRLI R,-40
AOBJN D,GFSP1
LPROG==.
JRST GFSPR
DEPHASE
;garbage collector sweep
GCSWP: MOVSI R,GFSWPP
BLT R,LPROG
MOVEI F,NIL ;will become movei f,-1
MOVE D,C3GCS
FOO MOVEI R,FS
GCBTL1: HRLI R,X ;-(32-<fs&37>
MOVE S,(D)
GCBTL2: ROT S,X ;fs&37
AOBJN D,GFSP1
GFSPR: MOVE A,C1GCS
MOVE B,C2GCS
PUSHJ P,GCS0
SKIPN GCGAGV
JRST GCSP1
MOVE B,F
PUSHJ P,GCPNT
STRTIP [SIXBIT / FREE STG,!/]
MOVE B,FF
PUSHJ P,GCPNT
STRTIP [SIXBIT / FULL WORDS AVAILABLE←!/]
GCSP1: HRLZI S,X ;bottom of reg pdl+1
BLT S,NACS+3 ;reload ac's
SUB P,[XWD GCPK2-GCPK1,GCPK2-GCPK1] ;restore p
IFN ML2,<
MOVE SSTACK,SSTKSV
MOVE TSTACK,TSTKSV
>;ML2
JUMPE F,[ERR2 [SIXBIT /NO FREE STG LEFT!/]]
JUMPE FF,[ERR2 [SIXBIT /NO FW STG LEFT!/]]
MOVE R,RGC
MOVEI A,0
CALLI A,STIME ;time
ADDM A,GCTIM
POPJ P,
GCS0: MOVEI FF,0
GCS1: ILDB C,B
JUMPN C,GCS2
HRRZM FF,(A)
HRRZ FF,A
GCS2: AOBJN A,GCS1
POPJ P,
C1GCS: 0 ;(- length of fws) bottom of fws
C2GCS: XWD 100,X ;.=bottom of fws bit table
C3GCS: 0 ;-n wds in bt,,bt
GCGAG: EXCH A,GCGAGV#
POPJ P,
GCTIME: MOVE A,GCTIM
JRST FIX1A
TIME: MOVEI A,0
CALLI A,STIME
JRST FIX1A
; DCS 8-73 SPEAK -- Becomes an FSUBR, so that optional arg.
; can reset conscount
SPEAK: MOVE B,A ;POSSIBLE ARG LIST
MOVE A,CONSVAL# ;CONSES SINCE BEGINNING OR LAST RESET
JUMPE B,SPEK1 ;NO ARG, JUST REPORT
HLRZ A,(B) ;FSUBR, NEED TO EVALUATE ARG
PUSHJ P,EVAL
PUSHJ P,NUMVAL ;GET NUMERIC VALUE OF ARG
SPEK1: EXCH 1,CONSVAL ;UPDATE OR JUST REPORT
JRST FIX1A
GCPNT: MOVEI R,TTYO
MOVEI A,0
JUMPE B,PRINL1
HRRZ B,(B)
AOJA A,.-2
COMMENT ⊗
;tables for unfinished storage scheme
;storage allocation tables
LSPSIZ: 0 ;size of Lisp interpreter
BPSSIZ: 2000 ;size of binary program space
FSSIZ: ;size of free storage
OBLSIZ: 177 ;size of LISP OBLIST
FWSIZ: 1000 ;size of full word space
BTSIZ: 0
BTFSIZ: 0
PDLSIZ: 1000 ;size of regular push down stack
SPSIZ: 1000 ;size of special push down stack
⊗
SUBTTL GETSYM --- PAGE 17
R50MAK: PUSHJ P,PNAMUK
PUSH C,[0]
HRLI C,700
HRRI C,(SP)
MOVEI B,0
MK3: ILDB A,C
LDB A,R50FLD
CAMGE B,[50*50*50*50*50]
SKIPN A
POPJ P,
IMULI B,50
ADD B,A
JRST MK3
GETSYM: PUSHJ P,R50MAK
TLO B,040000 ;04 for globals
MOVE C,JOBSYM
MK7: CAMN B,(C)
JRST MK10 ;found
AOBJP C,.+2
AOBJN C,MK7
TLC B,140000 ;10 for locals
TLNE B,100000
JRST MK7-1
JRST FALSE
MK10: MOVE A,1(C) ;value
JRST FIX1A
PUTSYM: PUSH P,B
PUSHJ P,R50MAK
MOVE A,B
TLO A,040000 ;make global
SKIPL JOBSYM
AOS JOBSYM ;increment initial symbol table pointer
MOVN B,[XWD 2,2]
ADDB B,JOBSYM
MOVEM A,(B) ;name
POP P,1(B) ;value
JRST FALSE
.PATCH:BLOCK 20
SUBTTL ALVINE AND LOADER INTERFACES --- PAGE 18
;interface to alvine
ED: MOVEI 10,X
JRST (10)
PUSH P,A
HRRZ A,CORUSE
HRRM A,LST
AOS A
HRRM A,ED
MOVSI A,(SIXBIT /ED/)
PUSHJ P,SYSINI
HRLM A,LST
MOVNS A
PUSHJ P,MORCOR
PUSHJ P,SYSINP+1
POP P,A
JRST ED
GRINDEF: PUSH P,A
PUSHJ P,ED
POP P,A
JRST 2(10)
EXCISE: MOVEI A,ED+2
HRRM A,ED
MOVE A,JRELO
SETZM LDFLG# ;initial loader symbol table flag
CALLI A,CORE
JRST .+1
JSR IOBRST
JRST TRUE
XLIST
VAR
LIT
LIST
PAGE; lisp loader interface
LOAD: AOS B,CORUSE
MOVEM B,OLDCU#
MOVEM A,LDPAR#
JUMPE A,LOAD2
FOO MOVE B,VBPORG
SUBI B,INUM0
LOAD2: MOVEM B,RVAL# ;final destination of loaded code
MOVSI A,(SIXBIT /LOD/)
PUSHJ P,SYSINI
SUBI A,150 ;extra room for locations 0 to 137 and slop
PUSH P,A
MOVNS A ;length(loader)
HRRZM A,LODSIZ#
PUSHJ P,MORCOR ;expand core for loader
MOVEM A,LOWLSP# ;location of blt'ed low lisp
MOVN B,(P) ;length(loader)
ADD B,A
MOVEM B,HVAL# ;temporary destination of loaded code
HRLI A,0
BLT A,(B) ;blt up low lisp
HLL A,NAME+3 ;-length(loader)
HRRI A,137-1
PUSHJ P,SYSINP
SKIPE LDFLG
JRST LOAD3
SETOM LDFLG
MOVSI A,(SIXBIT /SYM/)
PUSHJ P,SYSINI
MOVNS A ;length symbols
PUSHJ P,MORCOR ;expand core for symbols
SKIPGE B,JOBSYM
SOS B ;if no symbol table, use original jobsym
HLRZ A,NAME+3 ;-length(symbols)
ADDB A,B
HLL A,NAME+3 ;symbol table iowd
PUSHJ P,SYSINP
HRRM B,JOBSYM
HLLZ A,NAME+3
ADDM A,JOBSYM
SKIPA
LOAD3: SOS JOBSYM ;want jobsym to point one below 1st symbol
MOVE 3,HVAL ;h
MOVE 5,RVAL ;r
MOVE 2,3
SUB 2,5 ;x=h-r
HRLI 5,12 ;(w)
HRLI 2,11 ;(v)
SETZB 1,4
JSP 0,140 ;call the loader
MOVEM 5,RLAST# ;last location loaded(in final area)
MOVE T,OLDCU
MOVE A,JOBSYM
MOVEM A,JOBSYM(T)
MOVE A,JOBREL
MOVEM A,JOBREL(T) ;update jobrel
HRLZ 0,LOWLSP
SOS LODSIZ
AOBJN 0,.+1
BLT 0,@LODSIZ ;blt down low lisp
MOVE 0,@LOWLSP
MOVE B,RLAST
MOVE A,RVAL
HRL A,HVAL
SKIPE LDPAR
JRST BINLD
MOVE C,RLAST ;new coruse
LDRET2: BLT A,(B) ;blt down loaded code
HRRZM C,CORUSE ;top of code loaded
MOVEI B,1
ANDCAM B,JOBSYM
SUB C,JOBSYM ;length of free core
ORCMI C,776000
AOJGE C,START ;no contraction
ADD C,JOBREL ;new top of core
MOVE B,C
PUSHJ P,MOVDWN
HRLM C,JOBSA
CALLI C,CORE ;contract core
JRST .+1
JRST START
BINLD: MOVEI C,INUM0(B)
FOO CAML C,VBPEND
JRST [ SETOM BPSFLG ;bps exceeded
JRST START]
FOO MOVEM C,VBPORG ;updat bporg
SOS C,OLDCU ;old top of core
JRST LDRET2
;DCS 8-73 LSPLOC -- LSPDEV and LSPPPN now control location of LISP.xxx files
SYSINI: MOVEM A,NAME+1
MOVE A,[LSPPPN]
MOVEM A,NAME+3
INIT 17
INITDV: LSPDEV
0
JRST AIN.4+1
LOOKUP NAME
JRST AIN.7+1
INPUT [IOWD 1,NAME+3 ;input size of file
0]
HLRO A,NAME+3
POPJ P,
NAME: SIXBIT /LISP/
0
0
0
SYSINP: MOVEM A,LST
INPUT LST
STATZ 740000
ERR1 AIN.8
RELEASE
POPJ P,
LST: 0
0
MOVDWN: HLRZ A,JOBSYM
JUMPE A,MOVS1
ADDI A,1(B)
HRL A,JOBSYM
HRRM A,JOBSYM
BLT A,(B) ;downward blt
POPJ P,
MOVSYM: MOVE B,JOBREL
HRLM B,JOBSA
HLRE A,JOBSYM
JUMPE A,MOVS1
ADDI B,1(A) ;new bottom of symbol table
MOVNI A,1(A)
ADD A,JOBSYM ;last loc of old symbol table
HRRM B,JOBSYM
PUSH P,C
MOVE B,JOBREL ;last loc of new symbol table
MOVE C,(A) ;simulated upward blt
MOVEM C,(B)
SUBI B,1
ADDI A,-1 ;lf+1,rt-1
JUMPL A,.-4
POP P,C
POPJ P,
MOVS1: HRRZM B,JOBSYM
POPJ P,
;enter with size needed in a
;exit with pointer in a to core
MORCOR: PUSH P,B
HRRZ B,JOBSYM
SUB B,CORUSE
SUBM A,B
JUMPL B,EXPND2
ADD B,JOBREL ;new core size
CALLI B,CORE ;expand core
ERR1 [SIXBIT /CANT EXPAND CORE !/]
PUSH P,A
PUSHJ P,MOVSYM
POP P,A
EXPND2: MOVE B,CORUSE
ADDM A,CORUSE
MOVE A,B
POP P,B
POPJ P,
SUBTTL REALLOC CODE --- PAGE 19
;relocator code moved from strange position
STRT: MOVE A,JOBREL
HRLM A,JOBSA
MOVEM A,JOSV# ;new top of core
SUB A,JRELO# ;length of extra core
JUMPE A,RREL4 ;no expansion
SKIPG A
JRST 4,0 ;smaller core -- bitch
MOVEI F,ED+2
HRRM F,ED
MOVE F,EFWSO#
SUB F,FWSO# ;old length of fws
HRRZS B,A
ACHLOC: ASH A,-2 ;1/4 of new core to fws
ADD A,F ;new length of fws
MOVE C,B
ASH C,-6 ;1/64 of new core to each pdl
MOVE AR1,C
HRL AR1,C
HLRZ AR2A,SC2 ;-old length of spec pdl
ADD AR2A,JOSV ;new bottom of spec pdl
HLL AR2A,SC2 ;old length of spec pdl
SUB AR2A,AR1 ;new pointer for spec pdl
MOVEM AR2A,SC2
MOVNS C2 ;old reg pdl pointer
HLRZ AR1,C2 ;old length of reg pdl
ADD C,AR1 ;new length of reg pdl
HRRZ B,AR2A ;new bottom of reg pdl
SUB B,FSO#
MOVEI T,44 ;1/36 space for fws bit tables
IDIVM A,T ;new length of fws bit tables
AOS T
SUB B,T
SUB B,A
SUB B,C
MOVEI TT,41 ;1/33 space for fs bit table
IDIVM B,TT ;new length of fs bit table
SUBI B,1(TT) ;new length of fs
ADD B,FSO ;new bottom of fs
HRRM B,GCP1
MOVN SP,B ;- new bottom of fws
HRRM SP,GCMFWS
HRLZM A,C1GCS
MOVNS C1GCS ;- new length of fws
HRRM B,C1GCS
ADDI B,-1(A) ;new top of fws
AOS B
MOVE SP,FSO
LSH SP,-5
SUBM B,SP
HRRM SP,GCBTP2 ;magic number for bit table references
HRRM SP,GCBTP1
HRLM B,C3GC ;bottom of bit tables --- for bit table zeroing
HRRM B,GCP2
HRRM B,GCP
MOVNI SP,-1(TT)
HRLM SP,C3GCS
HRRM B,C3GCS ;iowd for bit table sweep
AOS B
MOVE SP,FSO
ANDI SP,37
HRRM SP,GCBTL2 ;magic number to position bit table word
SUBI SP,↑D32
HRRM SP,GCBTL1
HRRM B,C3GC ;bottom of bit table
ADDI B,-1(TT)
HRRM B,C2GCS ;bottom of fws bit table
AOS B
HRRM B,C2GC
ADDI B,-1(T)
HRRM B,GCP5 ;top of bit tables
AOS B ;bottom of reg pdl
HRRZ A,RHX2 ;oblist pointer
MOVEM A,(B)
HRRM B,GCP3 ;room for acs
AOS B
HRRM B,GCSP1
HRRM B,GCP4 ;room for acs
ADDI B,10
HRRM B,GCP41 ;top of ac area
AOS B
HRRM B,C2 ;reg pdl bottom
MOVNI A,-20(C)
HRLM A,C2 ;reg pdl size
HRRZ A,JOSV
HRRZM A,JRELO ;new top of core
MOVE A,GCP1
HRRM A,.+4
MOVE A,FWSO
HRRM A,.+1
MOVE A,.(F) ;old bottom of fws *
MOVEM A,.(F) ;new bottom of fws *
SOJGE F,.-2 ;f has length (old) of fws
HRRZ AR1,GCP1
SUB AR1,FWSO ;displacement for fws
MOVE AR2A,FSO ;bottom of fs
RREL1: HLRZ A,(AR2A)
CAMG A,EFWSO
CAMGE A,FWSO
JRST RREL2
ADD A,AR1
HRLM A,(AR2A) ;fix car pointer
RREL2: HRRZ A,(AR2A)
CAMG A,EFWSO
CAMGE A,FWSO
JRST RREL3
ADD A,AR1
HRRM A,(AR2A) ;fix cdr pointer
RREL3: CAMGE AR2A,FWSO
AOJA AR2A,RREL1
MOVE A,GCP1 ;bottom of fws
HRRZM A,FWSO
MOVE A,C3GC ;bottom of bit table + 1
HRRZM A,EFWSO
RREL4: CLEARB F,DDTIFG
JSR IOBRST
JRST START
RLOCA: MOVE B,AR1
HRLI AR1,BFWS
HRRI AR1,FS(B)
HRRZI AR2A,EFWS-BFWS(AR1)
BLT AR1,(AR2A)
MOVEI AR1,FS-BFWS(B)
MOVEI AR2A,BFWS-1
REL1: HLRZ A,(AR2A)
CAILE A,EFWS
JRST REL2
CAIGE A,BFWS
JSP R,REL4
ADD A,AR1
REL2: HRLM A,(F)
HRRZ A,(AR2A)
CAILE A,EFWS
JRST REL3
CAIGE A,BFWS
JSP R,REL4
ADD A,AR1
REL3: HRRM A,(F)
SOS F
CAILE AR2A,FS
SOJA AR2A,REL1
JRST RREL4
REL4: CAIL A,FS
ADD A,FF
JRST 1(R)
REHASH:
FOO MOVEI A,BFWS
PUSH P,A
HRRM A,RHX2
HRRM A,RHX5
RH4: MOVSI B,X ;*
FOO HRRZI A,BFWS+1(B)
FOO MOVEM A,BFWS(B)
AOBJN B,.-2
FOO SETZM BFWS(B)
MOVSI AR2A,-BCKETS
RH1:
FOO HLRZ C,OBTBL(AR2A)
RH3: JUMPE C,RH2
HLRZ A,(C)
PUSH P,C
PUSH P,AR2A
PUSHJ P,INTERN
POP P,AR2A
POP P,C
HRRZ C,(C)
JRST RH3
RH2: AOBJN AR2A,RH1
SETZM HASHFG
POP P,A
HRRM A,@GCP3
FOO MOVEM A,OBLIST
JRST START
SUBTTL LISP ATOMS AND OBLIST --- PAGE 20
VAR
LIT
FS:
DEFINE MAKBUC (A,%B)
<DEFINE OBT'A <%B=.>
XWD %B,IFN <<BCKETS-1>-A>,<.+1>
IF1 <%B=0>>
DEFINE ADDOB (A,C,%B)
<OBT'A
DEFINE OBT'A<%B=.>
IF1 <%B=0>
XWD C,%B>
DEFINE PUTOB (A,B)
<ZZ==<ASCII /A/>←<-1>
ZZ==-ZZ/BCKETS*BCKETS+ZZ
ADDOB \ZZ,B>
DEFINE PSTRCT (A)
<ZZ==[ASCII /A/]
LENGTH ZY,A
REPEAT <ZY-1>/5,<XWD ZZ,.+1
ZZ==ZZ+1>
XWD ZZ,0>
DEFINE MKAT (A,B,C,D)
<XLIST
IRP A< PUTOB A,.+1
D XWD -1,.+1
XWD B,.+1
XWD C'A,.+1
XWD PNAME,.+1
XWD .+1,0
PSTRCT A>
LIST>
DEFINE MKAT1 (A,B,C,D)
<XLIST
IRP C <PUTOB C,.+1
XWD -1,.+1
XWD B,.+1
XWD D'A,.+1
XWD PNAME,.+1
XWD .+1,0
PSTRCT C>
LIST>
DEFINE LENGTH (A,B)
<A==0
IRPC B,<A==A+1>>
DEFINE ML1 (A)<IRP A,<
V'A= INUM0+A
MKAT A,SYM,V
>>
DEFINE ML (A)<
XLIST
IRP A,<PUTOB A,.+1
A: XWD -1,.+1
XWD PNAME,.+1
XWD .+1,0
PSTRCT A>
LIST>
OBTBL:
OBLIST: ZZ==0
XLIST
REPEAT BCKETS,<MAKBUC \ZZ
ZZ==ZZ+1>
LIST
MKAT<RPLACA,RPLACD,MINUS,TERPRI,READ,CAR,CDR,CAAR>,SUBR
MKAT<CADR,CDAR,CDDR,CAAAR,CAADR,CADAR,CADDR,CDAAR,CDADR,CDDAR,CDDDR>,SUBR
MKAT<CAAAAR,CAAADR,CAADAR,CAADDR,CADAAR,CADADR,CADDAR,CADDDR,CDAAAR>,SUBR
MKAT<CDAADR,CDADAR,CDADDR,CDDAAR,CDDADR,CDDDAR,CDDDDR,MAKNUM,CONS>,SUBR
MKAT<ATOM,EQ,PRIN1,PRINT,RETURN,EXPLODE,SASSOC,ASSOC>,SUBR
MKAT<GCGAG,CHRCT,LINELENGTH,NUMBERP,EQUAL,SUBST,GET,INTERN,MEMBER>,SUBR
MKAT<ED,LOAD,MAKNAM,READCH,NOT,NULL,GENSYM,ZEROP,DIVIDE,GCD>,SUBR
MKAT<TIME,FIX,SET,PROG2,LENGTH,READLIST,LAST,ADD1,SUB1>,SUBR
MKAT<GCTIME,REVERSE,MAPLIST,GC,GETL,BAKGAG,MEMQ>,SUBR
MKAT<PUTPROP,PRINC,FLATSIZE,ERR,MAPCAR,EXAMINE,DEPOSIT,LSH>,SUBR
MKAT<NCONS,XCONS,REMPROP,ARG,SETARG,NOUUO,CNTSET,MINUSP,MAP,MAPC>,SUBR
MKAT<OUTC,INC,DDTIN,INITFN,EXCISE,REMAINDER,ABS>,SUBR
MKAT<PGLINE,USETI,USETO,BUFFER,CHSETI,CHSETO,ML2SET,CHRVAL>,SUBR
MKAT EXPLODEC,SUBR,%
MKAT TYO,SUBR,I
MKAT TYI,SUBR,I
CEVAL=.+1
MKAT1 EVAL,SUBR,*EVAL
MKAT <LIST,COND,PROG,SETQ,INPUT,OUTPUT,GRINDEF>,FSUBR
MKAT<ERRSET,REMOB,OR,GO,ARRAY,STORE,SPEAK>,FSUBR
MKAT<AND,DEFPROP,CSYM,EXARRAY,INOUT>,FSUBR
MKAT1 QUOTE,FSUBR,FUNCTION
MKAT1 FUNCT,FSUBR,*FUNCTION
MKAT <APPEND,NCONC,BOOLE,APPLY>,LSUBR
MKAT EVAL,LSUBR,O
MKAT ASCII,SUBR,A
MKAT QUOTE,FSUBR,,CQUOTE:
MKAT INUM0,SYM
PUTOB T,.+1
TRUTH: XWD -1,.+1
XWD VALUE,.+1
XWD VTRUTH,.+1
XWD PNAME,.+1
XWD .+1,0
PSTRCT T
VTRUTH: TRUTH
PUTOB NIL,0
CNIL2: XWD VALUE,.+1
XWD VNIL,.+1
XWD PNAME,.+1
XWD .+1,0
PSTRCT NIL
VNIL: NIL
PUTOB *SAVIOB,.+1
XWD -1,.+1
XWD VALUE,.+1
XWD SAVIOB,.+1
XWD PNAME,.+1
XWD .+1,0
PSTRCT *SAVIOB
SAVIOB: NIL
MKAT1 LCALL,SYM,*LCALL,INUM0+%
MKAT1 AMAKE,SYM,*AMAKE,INUM0+%
MKAT1 UDT,SYM,*UDT,INUM0+%
MKAT1 %NOPOINT,VALUE,*NOPOINT
%NOPOINT: NIL
UNBOUND: XWD -1,.+1
XWD PNAME,.+1
XWD .+1,0
PSTRCT UNBOUND
MKAT1 EXPN1,SUBR,*EXPAND1
MKAT1 EXPAND,SUBR,*EXPAND
MKAT1 PLUS,SUBR,*PLUS,.
MKAT1 DIF,SUBR,*DIF,.
MKAT1 QUO,SUBR,*QUO,.
MKAT1 TIMES,SUBR,*TIMES,.
MKAT1 APPEND,SUBR,*APPEND,.
MKAT1 RSET,SUBR,*RSET,.
MKAT1 GREAT,SUBR,*GREAT,.
MKAT1 LESS,SUBR,*LESS,.
MKAT1 PUTSYM,SUBR,*PUTSYM
MKAT1 GETSYM,SUBR,*GETSYM
ML1 <SPECBIND,SPECSTR,FIX1A,NSTR>
PUTOB NUMVAL,.+1
XWD -1,.+1
XWD SUBR,.+1
XWD NUMVAL,.+1
XWD SYM,.+1
XWD NUMVAL+INUM0,.+1
XWD PNAME,.+1
XWD .+1,0
PSTRCT NUMVAL
MKAT <OBLIST,BASE,IBASE,BPEND,BPORG>,VALUE,V
VOBLIST: OBLIST
VBASE: 8+INUM0
VIBASE: 8+INUM0
ML <PNAME,FIXNUM,FLONUM,VALUE,LAMBDA,SUBR,FSUBR,EXPR,FEXPR,SYM,∨
$EOF$,LABEL,FUNARG,LSUBR,MACRO>
PUTOB ?,.+1
QST: XWD -1,.+1
XWD PNAME,.+1
XWD .+1,0
PSTRCT ?
VBPORG: INUM0
VBPEND: INUM0
MKAT ACHLOC,SYM
BFWS:
XLIST
LIT
LIST
EFWS: 0
SUBTTL LISP STORAGE ALLOCATOR (ONCE ONLY) --- PAGE 21
SBPS: 2000
ALLNUM: MOVSI A,400000 ;high bit on for no digits
INCHRW C
CAIN C,RUBOUT
JRST [OUTSTR [ASCIZ /XXX /]
JRST ALLNUM]
CAIL C,"0"
CAILE C,"9"
POPJ P,
TLZ A,400000 ;turn off hi bit on digit
IMULI A,10
ADDI A,-"0"(C)
JRST ALLNUM+1
ALLPDL: BLOCK 10
ALLOC: MOVEI P,ALLPDL-1
MOVE A,JOBREL
HRRZM A,JRELO
HRLM A,JOBSA
CALLI RESET
PUSHJ P,FORSET ;initialize tty output info
OUTSTR [ASCIZ /
ALLOC? /]
INCHRW C
CAIGE C,"O"
JRST ALLC00
OUTSTR [ASCIZ /
FULL WDS=/]
PUSHJ P,ALLNUM
SKIPGE A
MOVEI A,400
HRRM A,ALLC02
OUTSTR [ASCIZ /
BIN.PROG.SP=/]
PUSHJ P,ALLNUM
SKIPGE A
MOVEI A,2000
HRRZM A,SBPS
OUTSTR [ASCIZ /
SPEC.PDL=/]
PUSHJ P,ALLNUM
SKIPGE A
MOVEI A,1000
HRRM A,ALLC20
MOVNS A
HRRM A,ALLC21
OUTSTR [ASCIZ /
REG. PDL=/]
PUSHJ P,ALLNUM
SKIPGE A
MOVEI A,1000
HRRM A,ALLC30
OUTSTR [ASCIZ /
HASH=/]
PUSHJ P,ALLNUM
CAIG A,BCKETS
JRST ALLC00
HRRM A,INT1
MOVNS A
HRRM A,RH4
SETOM HASHFG
ALLC00: MOVEI A,DEBUGO
HRRM A,JOBREN
MOVEI A,LISPGO
HRRM A,JOBSA
OUTSTR [ASCIZ /
/]
MOVEI A,FS
ADDM A,VBPORG
ADD A,SBPS
HRRZM A,FSO
SOS A
ADDM A,VBPEND
MOVE A,JRELO
ALLC20: SUBI A,1000
ALLC21: HRLI A,-1000
MOVEM A,SC2
SUB A,FSO
HRRZS B,A
ASH A,-4
ALLC02: ADDI A,400
MOVE C,B
ASH C,-6
ALLC30: ADDI C,1000
;stg order prgm bps fs fws bt btf pdlac pdl sp
MOVEI T,44
IDIVM A,T
AOS T ;size of btf
SUB B,T
SUB B,A
SUB B,C ;remaining storage
MOVEI TT,↑D32+1
IDIVM B,TT ;bt size -1
SUBI B,1(TT) ;free storage size
ADD B,SBPS
HRRZ AR1,B
ADDI B,FS
HRRZM B,FWSO
HRRM B,GCP1 ;b hac top of fs
MOVN SP,B
HRRM SP,GCMFWS
HRLZM A,C1GCS ;length of fws
MOVNS C1GCS
HRRM B,C1GCS
ADDI B,-1(A) ;bottom of bt-1
AOS B
MOVE SP,FSO
MOVE FF,SBPS
MOVEI F,BFWS-1(FF)
LSH SP,-5
SUBM B,SP
HRRM SP,GCBTP2
HRRM SP,GCBTP1
HRLM B,C3GC
HRRM B,GCP2
HRRM B,GCP
HRRZM B,EFWSO
MOVNI SP,-1(TT)
HRLM SP,C3GCS
HRRM B,C3GCS
AOS B
MOVE SP,FSO
ANDI SP,37
HRRM SP,GCBTL2
SUBI SP,↑D32
HRRM SP,GCBTL1
HRRM B,C3GC
ADDI B,-1(TT)
HRRM B,C2GCS
AOS B
HRRM B,C2GC
ADDI B,-1(T)
HRRM B,GCP5
AOS B
MOVEI A,OBTBL
ADD A,SBPS
MOVEM A,(B)
HRRM B,GCP3
AOS B
HRRM B,GCSP1
HRRM B,GCP4
ADDI B,10
HRRM B,GCP41
AOS B
HRRM B,C2
MOVNI A,-20(C)
HRLM A,C2
MOVEI C,FOOLST
REL5: MOVE B,(C)
HRRZ A,(B)
ADD A,FF
HRRM A,(B)
HLR B,B
HRRZ A,(B)
ADD A,FF
HRRM A,(B)
CAIGE C,EFOLST-1
AOJA C,REL5
JRST RLOCA
COMMENT ⊗
;unfinished allocator for new storage management scheme
SUBTTL LISP STORAGE ALLOCATOR (ONCE ONLY) --- PAGE 21
SBPS: 2000
ALPRNT: OUTCHR ["="]
PUSH P,A
MOVEI C,1
ALPRN1: LSH A,-3
JUMPE A,ALPRN2
IMULI C,10
JRST ALPRN1
ALPRN2: MOVE A,(P)
ALPRN3: IDIV A,C
ADDI A,"0"
OUTCHR A
IDIVI C,10
JUMPE C,ALPRN4
MOVE A,B
JRST ALPRN3
ALPRN4: POP P,A
OUTCHR ["="]
POPJ P,
ALLNUM: PUSHJ P,ALPRNT
MOVSI B,400000 ;high bit on for no digits
ALLRD1: INCHWL C
CAIN C,175 ;is it an altmode
JRST ALLALT
CAIN C,15 ;is it a carriage return
JRST ALLCR
CAIN C,12 ;is it a linefeed
JRST ALLLF
CAIL C,"0"
CAILE C,"9"
JRST ALLERR
TLZ B,400000 ;turn off hi bit on digit
IMULI B,10
ADDI B,-"0"(C)
JRST ALLRD1
ALLERR: CLRBFI
JSP T,(T) ;repeat last question
JRST ALLNUM
ALLALT: OUTSTR [ASCIZ/
/]
JSP T,1(T)
ALALT1: PUSHJ P,ALPRNT
MOVSI B,400000
OUTSTR [ASCIZ /
/]
JSP T,1(T)
JRST ALALT1
ALLCR: INCHWL C
ALLLF: JSP T,1(T)
JRST ALLNUM
ALLPDL: BLOCK 10
SYMMAK: MOVEI ALLOC
HRRM JOBSA
HRRZ 1,JOBFF
TRZ 1,177
ADDI 1,74
CAMGE 1,JOBFF
ADDI 1,200
MOVEI 2,200(1)
LSH 2,-7
MOVEM 2,LSPSMS
HLRE 2,JOBSYM
HRLM 2,LSPSMS
SUBM 1,2
MOVE 3,2
CALLI 3,11
HALT
HRL 1,JOBSYM
BLT 1,-1(2)
OUTSTR [ASCIZ /SAVE ME!/]
CALLI 12
ALLOC: MOVEI P,ALLPDL-1
MOVE A,JOBREL
HRRZM A,JRELO
HRLM A,JOBSA
CALLI RESET
OUTSTR [ASCIZ /
ALLOC? /]
INCHWL C
CAIGE C,"O"
JRST ALLC00
CLRBFI
MOVEI T,ALLNUM
ALLFW: OUTSTR [ASCIZ /FULL WDS/]
MOVE A,FWSIZ
JSP T,(T)
JRST ALLFW
SKIPGE A
MOVE A,BPSSIZ
HRRM A,ALLC02
ALLBPS:OUTSTR [ASCIZ /BIN.PROG.SP/]
MOVE A,BPSSIZ
JSP T,(T)
JRST ALLBPS
SKIPGE A
MOVE A,BPSSIZ
MOVEM A,BPSSIZ
HRRZM A,SBPS
ALLSP: OUTSTR [ASCIZ /SPEC.PDL/]
MOVE A,SPSIZ
JSP T,(T)
JRST ALLSP
SKIPGE A
MOVE A,SPSIZ
HRRM A,ALLC20
MOVNS A
HRRM A,ALLC21
ALLRP: OUTSTR [ASCIZ /REG. PDL/]
MOVE A,PDLSIZ
JSP T,(T)
JRST ALLRP
SKIPGE A
MOVE A,PDLSIZ
HRRM A,ALLC30
ALLOBL: OUTSTR [ASCIZ /HASH/]
MOVE A,OBLSIZ
JSP T,(T)
JRST ALLOBL
CAMG A,OBLSIZ
JRST ALLC00
HRRM A,INT1
MOVNS A
HRRM A,RH4
SETOM HASHFG
ALLC00: MOVEI A,DEBUGO
HRRM A,JOBREN
MOVEI A,LISPGO
HRRM A,JOBSA
OUTSTR [ASCIZ /
/]
MOVEI A,FS
ADDM A,VBPORG
ADD A,SBPS
HRRZM A,FSO
SOS A
ADDM A,VBPEND
MOVE A,JRELO
ALLC20: SUBI A,1000
ALLC21: HRLI A,-1000
MOVEM A,SC2
SUB A,FSO
HRRZS B,A
ASH A,-4
ALLC02: ADDI A,400
MOVE C,B
ASH C,-6
ALLC30: ADDI C,1000
;stg order prgm bps fs fws bt btf pdlac pdl sp
MOVEI T,44
IDIVM A,T
AOS T ;size of btf
SUB B,T
SUB B,A
SUB B,C ;remaining storage
MOVEI TT,↑D32+1
IDIVM B,TT ;bt size -1
SUBI B,1(TT) ;free storage size
ADD B,SBPS
HRRZ AR1,B
ADDI B,FS
HRRZM B,FWSO
HRRM B,GCP1 ;b hac top of fs
MOVN SP,B
HRRM SP,GCMFWS
HRLZM A,C1GCS ;length of fws
MOVNS C1GCS
HRRM B,C1GCS
ADDI B,-1(A) ;bottom of bt-1
AOS B
MOVE SP,FSO
MOVE FF,SBPS
MOVEI F,BFWS-1(FF)
LSH SP,-5
SUBM B,SP
HRRM SP,GCBTP2
HRRM SP,GCBTP1
HRLM B,C3GC
HRRM B,GCP2
HRRM B,GCP
HRRZM B,EFWSO
MOVNI SP,-1(TT)
HRLM SP,C3GCS
HRRM B,C3GCS
AOS B
MOVE SP,FSO
ANDI SP,37
HRRM SP,GCBTL2
SUBI SP,↑D32
HRRM SP,GCBTL1
HRRM B,C3GC
ADDI B,-1(TT)
HRRM B,C2GCS
AOS B
HRRM B,C2GC
ADDI B,-1(T)
HRRM B,GCP5
AOS B
MOVEI A,OBTBL
ADD A,SBPS
MOVEM A,(B)
HRRM B,GCP3
AOS B
HRRM B,GCSP1
HRRM B,GCP4
ADDI B,10
HRRM B,GCP41
AOS B
HRRM B,C2
MOVNI A,-20(C)
HRLM A,C2
MOVEI C,FOOLST
REL5: MOVE B,(C)
HRRZ A,(B)
ADD A,FF
HRRM A,(B)
HLR B,B
HRRZ A,(B)
ADD A,FF
HRRM A,(B)
CAIGE C,EFOLST-1
AOJA C,REL5
JRST RLOCA
⊗
I=0
DEFINE GARP (A,B)
<XWD FOO'A,FOO'B>
FOO 0
FOOLST:
XLIST
REPEAT <FOOCNT/2>,<
GARP (\I,\<I+1>)
I=I+2>
LIST
EFOLST:
DEFINE MKENT (A)<
INTERNAL A>
MKENT <EVBIG,NUMBP2,OPOV,NUMV2,NUMV3,NUMV4,OPR,FLOOV,FIX2>
MKENT <NUM1,NUM3,BPR,FWCONS,FALSE,TRUE,FW0CNS,NCONS>
MKENT <READ,READP1,MAKNUM,PRIN1,PRINT,EXPLODE,SASSOC,EQUAL,SUBST>
MKENT <CHCT,LINL,OLDCH,FLATSIZE,TYI,RATOM,CHRCT,TYOD>
MKENT <GET,INTERN,REMOB,MAKNAM,GENSYM,FIX,LENGTH,READLIST,PATOM>
MKENT <LAST,INC,OUTC,FIX1A,NUMVAL,REVERSE,MAPLIST,GC,GETL,PUTPROP>
MKENT <ERR,MAPCAR,REMPROP,LIST,SETQ,ERRSET,REMOB,ARRAY,APPEND>
MKENT <SPECBIND,SPECSTR,XCONS,ATOM,READCH,SET,NCONC,PRINC>
MKENT <CONS,ACONS,CTY,FP7A1,TERPRI,LSPRET,PSAV1,BKTRC>
MKENT <TYO,ITYO,IGSTRT,NOINFG,CHRTAB,EVAL,OEVAL,.APPEND,INPUT,OUTPUT>
MKENT <INOUT, USETI, USETO, BUFFER, CHSETI, CHSETO, ML2SET, .PATCH>
END ALLOC